Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ
Files:
218 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP.m

    r613 r623  
    1 OCXOCMP ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules) ;3/21/01  08:50
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN      ;
    6         ;
    7         N OCXQ
    8         ;
    9         S OCXQ=$$READ("Y","Do you want to queue the compiler to run ","NO") Q:(OCXQ[U)  I OCXQ D  Q
    10         .D QUE^OCXOCMPV(10)
    11         .W !!,"Expert system compiler queued to run in 10 seconds."
    12         .W !,"You will be sent a Mailman bulletin when it has finished.",!!
    13         .H 2
    14         ;
    15 MAN     K ZTSK D MAN^OCXOCMPV Q  ;  Run the compiler (interactive/manual mode)
    16         ;                        ;  Ask for option settings.
    17         ;
    18 AUTO    D AUTO^OCXOCMPV Q  ; Run the compiler (Automatic mode)
    19         ;                  ; Program Execution Trace Mode OFF
    20         ;                  ; Elapsed time logging OFF
    21         ;                  ; Raw Data Logging OFF
    22         ;
    23 QUE     D QUE^OCXOCMPV(10) Q  ; Queue the compiler to run in the background
    24         ;                     ;  Uses option setting from last compile.
    25         ;                     ;   If no last compile then all options are
    26         ;                     ;    turned OFF as in Automatic mode.
    27 RUN     ;
    28         ;
    29         N OCX1,OCX2,OCX3,OCX4
    30         ;
    31         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(1,20)
    32         ;
    33         D MESG("Build list of Active Rules, Elements and Datafields...")
    34         D SETFLAG^OCXOCMPV ; H 1
    35         I $$EN^OCXOCMP9 D ERMESG("Compiler Aborted while building list of Rules, Elements and Datafields...") Q
    36         Q:$G(OCXWARN)
    37         ;
    38         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(2,20)
    39         ;
    40         S OCX1="" F  S OCX1=$O(^TMP("OCXCMP",$J,OCX1)) Q:'$L(OCX1)  D
    41         .S OCX2=0 F OCX3=0:1 S OCX2=$O(^TMP("OCXCMP",$J,OCX1,OCX2)) Q:'OCX2
    42         .D MESG("  "_$J(OCX3,5)_" "_OCX1_$S(OCX3=1:"",1:"S"))
    43         ;
    44         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(3,20)
    45         ;
    46         D MESG("Compile DataField Navigation code...")
    47         D SETFLAG^OCXOCMPV ; H 1
    48         I $$EN^OCXOCMP1 D ERMESG("Compiler Aborted due to Datafield syntax errors...") Q
    49         Q:$G(OCXWARN)
    50         ;
    51         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(4,20)
    52         ;
    53         S (OCX3,OCX1)=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1)) Q:'OCX1  D
    54         .S OCX2=0 F  S OCX2=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1,OCX2)) Q:'OCX2  S OCX3=OCX3+1
    55         D MESG("  "_$J(OCX3,5)_" DataField Navigation Code Array"_$S(OCX3=1:"",1:"s"))
    56         ;
    57         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(5,20)
    58         ;
    59         D MESG("Compile Element Evaluation code...")
    60         D SETFLAG^OCXOCMPV ; H 1
    61         I $$EN^OCXOCMP2 D ERMESG("Compiler Aborted due to Rule Element syntax errors...") Q
    62         Q:$G(OCXWARN)
    63         ;
    64         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(6,20)
    65         ;
    66         S (OCX1,OCX2)=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"A CODE",OCX1)) Q:'OCX1  S OCX2=OCX2+1
    67         D MESG("  "_$J(OCX2,5)_" Event Evaluation Code Array"_$S(OCX2=1:"",1:"s"))
    68         ;
    69         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(7,20)
    70         ;
    71         D MESG("Compile Element MetaCode...")
    72         D SETFLAG^OCXOCMPV ; H 1
    73         I $$EN^OCXOCMPM D ERMESG("Compiler Aborted due to Element metacode errors...") Q
    74         Q:$G(OCXWARN)
    75         ;
    76         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(8,20)
    77         ;
    78         S OCX1="",OCX2=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1)  S:($E(OCX1,1,3)="MCE") OCX2=OCX2+1
    79         D MESG("  "_$J(OCX2,5)_" Element Metacode Array"_$S(OCX2=1:"",1:"s"))
    80         ;
    81         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(9,20)
    82         ;
    83         D MESG("Get Compiler Function Code...")
    84         D SETFLAG^OCXOCMPV ; H 1
    85         I $$EN^OCXOCMPO D ERMESG("Compiler Aborted due to Compiler Function code errors...") Q
    86         Q:$G(OCXWARN)
    87         ;
    88         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(10,20)
    89         ;
    90         S OCX1="",OCX2=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1)  S:'($E(OCX1,1,3)="MCE") OCX2=OCX2+1
    91         D MESG("  "_$J(OCX2,5)_" Compiler Include Function"_$S(OCX2=1:"",1:"s"))
    92         ;
    93         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(12,20)
    94         ;
    95         D MESG("Compile Rule Element Relation code...")
    96         D SETFLAG^OCXOCMPV ; H 1
    97         I $$EN^OCXOCMP3 D ERMESG("Compiler Aborted due to Rule syntax errors...") Q
    98         Q:$G(OCXWARN)
    99         ;
    100         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(13,20)
    101         ;
    102         S (OCX1,OCX2)=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"RULE",OCX1)) Q:'OCX1  D
    103         .S OCX3=0 F  S OCX3=$O(^TMP("OCXCMP",$J,"RULE",OCX1,OCX3)) Q:'OCX3  S:$O(^(OCX3,"CODE",0)) OCX2=OCX2+1
    104         D MESG("  "_$J(OCX2,5)_" Rule Element Relation Code Array"_$S(OCX2=1:"",1:"s"))
    105         ;
    106         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(14,20)
    107         ;
    108         D MESG("Construct Decision Tree...")
    109         D SETFLAG^OCXOCMPV ; H 1
    110         I $$EN^OCXOCMP4 D ERMESG("Compiler Aborted due to Compiler errors...") Q
    111         Q:$G(OCXWARN)
    112         ;
    113         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(15,20)
    114         ;
    115         S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1
    116         D MESG("  "_$J(OCX2,5)_" Sub-Routine"_$S(OCX2=1:"",1:"s"))
    117         ;
    118         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(16,20)
    119         ;
    120         D MESG("Optimize Sub-Routines...")
    121         D SETFLAG^OCXOCMPV ; H 1
    122         I $$EN^OCXOCMP5 D ERMESG("Compiler Aborted due to Compiler errors...") Q
    123         Q:$G(OCXWARN)
    124         ;
    125         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(17,20)
    126         ;
    127         S OCX1=0 F OCX3=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1
    128         D MESG("  "_$J(OCX3,5)_" Sub-Routine"_$S(OCX3=1:"",1:"s"))
    129         D MESG("  "_(100-(((OCX3/OCX2)*1000)\1/10))_"% Optimization")
    130         ;
    131         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(18,20)
    132         ;
    133         D MESG("Assemble Routines...")
    134         D SETFLAG^OCXOCMPV ; H 1
    135         I $$EN^OCXOCMP6 D ERMESG("Compiler Aborted due to Compiler errors...") Q
    136         Q:$G(OCXWARN)
    137         ;
    138         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(19,20)
    139         ;
    140         S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"D CODE",OCX1)) Q:'OCX1
    141         D MESG("  "_$J(OCX2,5)_" OCXOZ* Routine"_$S(OCX2=1:"",1:"s"))
    142         ;
    143         D:($G(OCXAUTO)<2) STATUS^OCXOPOST(20,20)
    144         ;
    145         L -^OCXD(861,1)
    146         ;
    147         Q
    148         ;
    149 MESG(OCXX)      ;
    150         I '$G(OCXAUTO) W !!,OCXX
    151         I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
    152         Q
    153         ;
    154 ERMESG(OCXX)    ;
    155         N OCXY S OCXY=OCXX
    156         I '$G(OCXAUTO) W !!,OCXX
    157         I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
    158         S OCXERRM=OCXY
    159         Q
    160         ;
    161 READ(OCXZ0,OCXZA,OCXZB,OCXZL)   ;
    162         N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    163         Q:'$L($G(OCXZ0)) U
    164         S DIR(0)=OCXZ0
    165         S:$L($G(OCXZA)) DIR("A")=OCXZA
    166         S:$L($G(OCXZB)) DIR("B")=OCXZB
    167         F OCXLINE=1:1:($G(OCXZL)-1) W !
    168         D ^DIR
    169         I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    170         Q Y
    171         ;
    172         Q
    173         ;
    174 DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y
    175         Q
    176         ;
    177 CNT(X)  ;
    178         ;
    179         N CNT,D0
    180         S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0
    181         W !!,?10,X,"  ",CNT
    182         Q CNT
    183         ;
    184 DATE()  N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y
    185         ;
    186 CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99)
    187         ;
    188         ;
    189 VERSION()       Q $P($T(+3),";;",3)
    190         ;
     1OCXOCMP ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules) ;3/21/01  08:50
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN ;
     6 ;
     7 N OCXQ
     8 ;
     9 S OCXQ=$$READ("Y","Do you want to queue the compiler to run ","NO") Q:(OCXQ[U)  I OCXQ D  Q
     10 .D QUE^OCXOCMPV(10)
     11 .W !!,"Expert system compiler queued to run in 10 seconds."
     12 .W !,"You will be sent a Mailman bulletin when it has finished.",!!
     13 .H 2
     14 ;
     15MAN K ZTSK D MAN^OCXOCMPV Q  ;  Run the compiler (interactive/manual mode)
     16 ;                        ;  Ask for option settings.
     17 ;
     18AUTO D AUTO^OCXOCMPV Q  ; Run the compiler (Automatic mode)
     19 ;                  ; Program Execution Trace Mode OFF
     20 ;                  ; Elapsed time logging OFF
     21 ;                  ; Raw Data Logging OFF
     22 ;
     23QUE D QUE^OCXOCMPV(10) Q  ; Queue the compiler to run in the background
     24 ;                     ;  Uses option setting from last compile.
     25 ;                     ;   If no last compile then all options are
     26 ;                     ;    turned OFF as in Automatic mode.
     27RUN ;
     28 ;
     29 N OCX1,OCX2,OCX3,OCX4
     30 ;
     31 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(1,20)
     32 ;
     33 D MESG("Build list of Active Rules, Elements and Datafields...")
     34 D SETFLAG^OCXOCMPV ; H 1
     35 I $$EN^OCXOCMP9 D ERMESG("Compiler Aborted while building list of Rules, Elements and Datafields...") Q
     36 Q:$G(OCXWARN)
     37 ;
     38 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(2,20)
     39 ;
     40 S OCX1="" F  S OCX1=$O(^TMP("OCXCMP",$J,OCX1)) Q:'$L(OCX1)  D
     41 .S OCX2=0 F OCX3=0:1 S OCX2=$O(^TMP("OCXCMP",$J,OCX1,OCX2)) Q:'OCX2
     42 .D MESG("  "_$J(OCX3,5)_" "_OCX1_$S(OCX3=1:"",1:"S"))
     43 ;
     44 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(3,20)
     45 ;
     46 D MESG("Compile DataField Navigation code...")
     47 D SETFLAG^OCXOCMPV ; H 1
     48 I $$EN^OCXOCMP1 D ERMESG("Compiler Aborted due to Datafield syntax errors...") Q
     49 Q:$G(OCXWARN)
     50 ;
     51 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(4,20)
     52 ;
     53 S (OCX3,OCX1)=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1)) Q:'OCX1  D
     54 .S OCX2=0 F  S OCX2=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1,OCX2)) Q:'OCX2  S OCX3=OCX3+1
     55 D MESG("  "_$J(OCX3,5)_" DataField Navigation Code Array"_$S(OCX3=1:"",1:"s"))
     56 ;
     57 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(5,20)
     58 ;
     59 D MESG("Compile Element Evaluation code...")
     60 D SETFLAG^OCXOCMPV ; H 1
     61 I $$EN^OCXOCMP2 D ERMESG("Compiler Aborted due to Rule Element syntax errors...") Q
     62 Q:$G(OCXWARN)
     63 ;
     64 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(6,20)
     65 ;
     66 S (OCX1,OCX2)=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"A CODE",OCX1)) Q:'OCX1  S OCX2=OCX2+1
     67 D MESG("  "_$J(OCX2,5)_" Event Evaluation Code Array"_$S(OCX2=1:"",1:"s"))
     68 ;
     69 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(7,20)
     70 ;
     71 D MESG("Compile Element MetaCode...")
     72 D SETFLAG^OCXOCMPV ; H 1
     73 I $$EN^OCXOCMPM D ERMESG("Compiler Aborted due to Element metacode errors...") Q
     74 Q:$G(OCXWARN)
     75 ;
     76 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(8,20)
     77 ;
     78 S OCX1="",OCX2=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1)  S:($E(OCX1,1,3)="MCE") OCX2=OCX2+1
     79 D MESG("  "_$J(OCX2,5)_" Element Metacode Array"_$S(OCX2=1:"",1:"s"))
     80 ;
     81 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(9,20)
     82 ;
     83 D MESG("Get Compiler Function Code...")
     84 D SETFLAG^OCXOCMPV ; H 1
     85 I $$EN^OCXOCMPO D ERMESG("Compiler Aborted due to Compiler Function code errors...") Q
     86 Q:$G(OCXWARN)
     87 ;
     88 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(10,20)
     89 ;
     90 S OCX1="",OCX2=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1)  S:'($E(OCX1,1,3)="MCE") OCX2=OCX2+1
     91 D MESG("  "_$J(OCX2,5)_" Compiler Include Function"_$S(OCX2=1:"",1:"s"))
     92 ;
     93 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(12,20)
     94 ;
     95 D MESG("Compile Rule Element Relation code...")
     96 D SETFLAG^OCXOCMPV ; H 1
     97 I $$EN^OCXOCMP3 D ERMESG("Compiler Aborted due to Rule syntax errors...") Q
     98 Q:$G(OCXWARN)
     99 ;
     100 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(13,20)
     101 ;
     102 S (OCX1,OCX2)=0 F  S OCX1=$O(^TMP("OCXCMP",$J,"RULE",OCX1)) Q:'OCX1  D
     103 .S OCX3=0 F  S OCX3=$O(^TMP("OCXCMP",$J,"RULE",OCX1,OCX3)) Q:'OCX3  S:$O(^(OCX3,"CODE",0)) OCX2=OCX2+1
     104 D MESG("  "_$J(OCX2,5)_" Rule Element Relation Code Array"_$S(OCX2=1:"",1:"s"))
     105 ;
     106 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(14,20)
     107 ;
     108 D MESG("Construct Decision Tree...")
     109 D SETFLAG^OCXOCMPV ; H 1
     110 I $$EN^OCXOCMP4 D ERMESG("Compiler Aborted due to Compiler errors...") Q
     111 Q:$G(OCXWARN)
     112 ;
     113 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(15,20)
     114 ;
     115 S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1
     116 D MESG("  "_$J(OCX2,5)_" Sub-Routine"_$S(OCX2=1:"",1:"s"))
     117 ;
     118 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(16,20)
     119 ;
     120 D MESG("Optimize Sub-Routines...")
     121 D SETFLAG^OCXOCMPV ; H 1
     122 I $$EN^OCXOCMP5 D ERMESG("Compiler Aborted due to Compiler errors...") Q
     123 Q:$G(OCXWARN)
     124 ;
     125 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(17,20)
     126 ;
     127 S OCX1=0 F OCX3=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1
     128 D MESG("  "_$J(OCX3,5)_" Sub-Routine"_$S(OCX3=1:"",1:"s"))
     129 D MESG("  "_(100-(((OCX3/OCX2)*1000)\1/10))_"% Optimization")
     130 ;
     131 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(18,20)
     132 ;
     133 D MESG("Assemble Routines...")
     134 D SETFLAG^OCXOCMPV ; H 1
     135 I $$EN^OCXOCMP6 D ERMESG("Compiler Aborted due to Compiler errors...") Q
     136 Q:$G(OCXWARN)
     137 ;
     138 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(19,20)
     139 ;
     140 S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"D CODE",OCX1)) Q:'OCX1
     141 D MESG("  "_$J(OCX2,5)_" OCXOZ* Routine"_$S(OCX2=1:"",1:"s"))
     142 D MESG("  "_OCXLCNT_" Lines of code generated.")
     143 ;
     144 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(20,20)
     145 ;
     146 L -^OCXD(861,1)
     147 ;
     148 Q
     149 ;
     150MESG(OCXX) ;
     151 I '$G(OCXAUTO) W !!,OCXX
     152 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
     153 Q
     154 ;
     155ERMESG(OCXX) ;
     156 N OCXY S OCXY=OCXX
     157 I '$G(OCXAUTO) W !!,OCXX
     158 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
     159 S OCXERRM=OCXY
     160 Q
     161 ;
     162READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
     163 N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     164 Q:'$L($G(OCXZ0)) U
     165 S DIR(0)=OCXZ0
     166 S:$L($G(OCXZA)) DIR("A")=OCXZA
     167 S:$L($G(OCXZB)) DIR("B")=OCXZB
     168 F OCXLINE=1:1:($G(OCXZL)-1) W !
     169 D ^DIR
     170 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     171 Q Y
     172 ;
     173 Q
     174 ;
     175DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y
     176 Q
     177 ;
     178CNT(X) ;
     179 ;
     180 N CNT,D0
     181 S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0
     182 W !!,?10,X,"  ",CNT
     183 Q CNT
     184 ;
     185DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y
     186 ;
     187CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99)
     188 ;
     189 ;
     190VERSION() Q $P($T(+3),";;",3)
     191 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP6.m

    r613 r623  
    1 OCXOCMP6        ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines) ;1/05/04  14:33
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         Q:$G(OCXWARN) 1
    8         N OCXD0,OCXD1,OCXRN,OCXSCNT,OCXOFF
    9         ;
    10         W:'$G(OCXAUTO) !,?5,"Generate Extrinsic Function and Variables documentation..."
    11         S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0  D DOC^OCXOCMPT(OCXD0)
    12         ;
    13         K ^OCXS(860.3,"APGM")
    14         S OCXD0=0 F  S OCXD0=$O(^OCXS(860.3,OCXD0)) Q:'OCXD0  D
    15         .K ^OCXS(860.3,OCXD0,"RTN") I '$G(OCXAUTO) W:($X>60) ! W "."
    16         ;
    17         K ^TMP("OCXCMP",$J,"D CODE")
    18         ;
    19         W:'$G(OCXAUTO) !,?5,"Assign Subroutines to Routines..."
    20         S OCXRN=1,OCXD0=0
    21         D GETHDR(1)
    22         F  S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0  D  Q:OCXWARN
    23         .N OCXLLAB,OCXSKIP,OCXEXF,OCXSUB,OCXSIZE,OCXFILE,OCXCCODE,OCXDCODE,OCXLAST
    24         .I '$G(OCXAUTO) W:($X>60) ! W "."
    25         .S OCXLLAB=^TMP("OCXCMP",$J,"LINE",OCXD0)
    26         .S OCXSKIP=((OCXLLAB="UPDATE")!(OCXLLAB="LOG"))
    27         .S OCXSIZE=$$SIZE^OCXOCMP8(OCXRN,OCXD0)
    28         .S OCXLAST='$O(^TMP("OCXCMP",$J,"C CODE",OCXD0))
    29         .S OCXFILE=(OCXSIZE>OCXCRS)!(OCXLAST) S:OCXSKIP OCXFILE=0
    30         .I OCXFILE D
    31         ..K OCXEXF S OCXEXF=""
    32         ..I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS")
    33         ..S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  I 'OCXEXF(OCXSUB) D
    34         ...S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB
    35         ...S OCXSUB="" F  S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB)  D
    36         ....S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB))
    37         ..S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  D
    38         ...D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F")
    39         ..D APPEND^OCXOCMP8(OCXRN,"$")
    40         ..S OCXRN=OCXRN+1 D GETHDR(OCXRN)
    41         ..;
    42         .D APPEND^OCXOCMP8(OCXRN,OCXD0,"C",OCXLLAB)
    43         .I ($E(OCXLLAB,1,2)="EL") D
    44         ..S ^OCXS(860.3,"APGM",(+$E(OCXLLAB,3,$L(OCXLLAB))),(OCXLLAB_U_$$RNAM(OCXRN)))=""
    45         .S $P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,2)=$$RNAM(OCXRN)
    46         .Q:'OCXLAST
    47         .K OCXEXF S OCXEXF=""
    48         .I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS")
    49         .S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  I 'OCXEXF(OCXSUB) D
    50         ..S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB
    51         ..S OCXSUB="" F  S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB)  D
    52         ...S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB))
    53         .S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  D
    54         ..D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F")
    55         .D APPEND^OCXOCMP8(OCXRN,"$")
    56         ;
    57         W:'$G(OCXAUTO) !,?5,"Resolve Routine Line Tags..."
    58         S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0  D  Q:OCXWARN
    59         .I '$G(OCXAUTO) W:($X>60) ! W "."
    60         .N TEXT,RTN,TEMP,ALT,LABL,OBJ,PIEC
    61         .S RTN=$$RNAM(OCXD0)
    62         .K TEMP M TEMP=^TMP("OCXCMP",$J,"D CODE",OCXD0)
    63         .S OCXD1=0 F OCXOFF=0:1 S OCXD1=$O(TEMP(OCXD1)) Q:'OCXD1  D  Q:OCXWARN
    64         ..N TEXT,PIEC
    65         ..S TEXT=TEMP(OCXD1,0) Q:'(TEXT["||")
    66         ..;
    67         ..F PIEC=2:2:$L(TEXT,"||") D  Q:OCXWARN
    68         ...S LABL=$P(TEXT,"||",PIEC)
    69         ...I ($E(LABL,1,5)="LINE:") D  I 1
    70         ....S LABL=$G(^TMP("OCXCMP",$J,"LINE",+$P(LABL,":",2)))
    71         ....I '$L(LABL) D WARN^OCXOCMPV("Line Label not found: "_$P(TEXT,"|",2),$P($T(+1)," ",1)) Q
    72         ....S:($P(LABL,"^",2)=RTN) LABL=$P(LABL,"^",1)
    73         ...;
    74         ...E  I ($E(LABL,1,5)="LNTAG") D  I 1
    75         ....N D0,CNT
    76         ....S D0=OCXD1 F CNT=1:1 S D0=$O(TEMP(D0),-1)  Q:$L($P(TEMP(D0,0)," ",1))
    77         ....S LABL=$P(TEMP(D0,0)," ",1) S:(LABL["(") LABL=$P(LABL,"(",1)
    78         ....S LABL="(+$P($H,"","",2))_""<"_LABL_"+"_CNT_U_RTN_">"""
    79         ...;
    80         ...E  D WARN^OCXOCMPV("Unknown Compiler directive: "_LABL,$P($T(+1)," ",1)) Q
    81         ...;
    82         ...S $P(TEXT,"||",PIEC)=LABL
    83         ..;
    84         ..F  Q:'(TEXT["||")  S TEXT=$P(TEXT,"||",1)_$P(TEXT,"||",2,999)
    85         ..S TEMP(OCXD1,0)=TEXT
    86         .;
    87         .K ^TMP("OCXCMP",$J,"D CODE",OCXD0)
    88         .M ^TMP("OCXCMP",$J,"D CODE",OCXD0)=TEMP
    89         ;
    90         Q:OCXWARN 1
    91         W:'$G(OCXAUTO) !,?5,"Generate Subroutine and Call documentation..."
    92         S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0  D CALL^OCXOCMPT(OCXD0)
    93         ;
    94         W:'$G(OCXAUTO) !!,?5,"Delete Old OCXOZ* Routines..."
    95         S OCXRTEST=^%ZOSF("TEST"),OCXSAVE=^%ZOSF("SAVE"),OCXDEL=^%ZOSF("DEL")
    96         F OCXRN=1:1:1290 D
    97         .I '$G(OCXAUTO) W:($X>60) ! W:'(OCXRN#100) "."
    98         .S X=$$RNAM(OCXRN) X OCXRTEST I  X OCXDEL W:'$G(OCXAUTO) "!"
    99         ;
    100         W:'$G(OCXAUTO) !,?5,"File New OCXOZ* routines..."
    101         S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1
    102         F  S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0  D  Q:OCXWARN
    103         .I '$G(OCXAUTO) W:($X>60) ! W "."
    104         .D FILE^OCXOCMP8(OCXD0)
    105         S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1  D FILE^OCXOCMP8(OCXD0)
    106         ;
    107         Q OCXWARN
    108         ;
    109 GETHDR(RNUM)    ;
    110         ;
    111         N OCXREC,D0,EFC,OCXEFF,PIEC,TEXT
    112         S OCXREC(1,0)=$$RNAM(RNUM)_" ;SLC/RJS,CLA - Order Check Scan ;"_$$NOW
    113         S OCXREC(2,0)=$T(+2)
    114         S OCXREC(3,0)=$T(+3)
    115         S OCXREC(4,0)=" ;"
    116         S OCXREC(5,0)=" ; ***************************************************************"
    117         S OCXREC(6,0)=" ; ** Warning: This routine is automatically generated by the   **"
    118         S OCXREC(7,0)=" ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **"
    119         S OCXREC(8,0)=" ; ** will be lost the next time the rule compiler executes.    **"
    120         S OCXREC(9,0)=" ; ***************************************************************"
    121         S OCXREC(10,0)=" ;"
    122         I (RNUM=1) D
    123         .S OCXREC(11,0)=" ;    compiled code line length: "_OCXCLL
    124         .S OCXREC(12,0)=" ;        compiled routine size: "_OCXCRS
    125         .S OCXREC(13,0)=" ; triggered rule ignore period: "_OCXTSPI
    126         .S OCXREC(14,0)=" ;"
    127         .S OCXREC(15,0)=" ;   Program Execution Trace Mode: "_$S($G(OCXTRACE):" ON",1:"OFF")
    128         .S OCXREC(16,0)=" ;" ; " ;    Elapsed time logging: "_$S($G(OCXTLOG):" ON",1:"OFF")
    129         .S OCXREC(17,0)=" ;               Raw Data Logging: "_$S($G(OCXDLOG):(" ON  Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF")
    130         .S OCXREC(18,0)=" ; Compiler mode: "_$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):" ON",1:"OFF")
    131         .S OCXREC(19,0)=" ;   Compiled by: "_$P($G(^VA(200,+$G(DUZ),0)),U,1)_"  (DUZ="_(+$G(DUZ))_")"
    132         .S OCXREC(20,0)=" Q"
    133         .S OCXREC(21,0)=" ;"
    134         ;
    135         E  D
    136         .S OCXREC(11,0)=" Q"
    137         .S OCXREC(12,0)=" ;"
    138         ;
    139         M ^TMP("OCXCMP",$J,"D CODE",RNUM)=OCXREC
    140         Q
    141         ;
    142 RNAM(X) ;
    143         N CHAR
    144         S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    145         Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1))
    146         ;
    147 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y
    148         ;
    149 NOW()   N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y
    150         ;
     1OCXOCMP6 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines) ;1/05/04  14:33
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 Q:$G(OCXWARN) 1
     8 N OCXD0,OCXD1,OCXRN,OCXSCNT,OCXOFF
     9 ;
     10 S OCXLCNT=0
     11 ;
     12 W:'$G(OCXAUTO) !,?5,"Generate Extrinsic Function and Variables documentation..."
     13 S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0  D DOC^OCXOCMPT(OCXD0)
     14 ;
     15 K ^OCXS(860.3,"APGM")
     16 S OCXD0=0 F  S OCXD0=$O(^OCXS(860.3,OCXD0)) Q:'OCXD0  D
     17 .K ^OCXS(860.3,OCXD0,"RTN") I '$G(OCXAUTO) W:($X>60) ! W "."
     18 ;
     19 K ^TMP("OCXCMP",$J,"D CODE")
     20 ;
     21 W:'$G(OCXAUTO) !,?5,"Assign Subroutines to Routines..."
     22 S OCXRN=1,OCXD0=0
     23 D GETHDR(1)
     24 F  S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0  D  Q:OCXWARN
     25 .N OCXLLAB,OCXSKIP,OCXEXF,OCXSUB,OCXSIZE,OCXFILE,OCXCCODE,OCXDCODE,OCXLAST
     26 .I '$G(OCXAUTO) W:($X>60) ! W "."
     27 .S OCXLLAB=^TMP("OCXCMP",$J,"LINE",OCXD0)
     28 .S OCXSKIP=((OCXLLAB="UPDATE")!(OCXLLAB="LOG"))
     29 .S OCXSIZE=$$SIZE^OCXOCMP8(OCXRN,OCXD0)
     30 .S OCXLAST='$O(^TMP("OCXCMP",$J,"C CODE",OCXD0))
     31 .S OCXFILE=(OCXSIZE>OCXCRS)!(OCXLAST) S:OCXSKIP OCXFILE=0
     32 .I OCXFILE D
     33 ..K OCXEXF S OCXEXF=""
     34 ..I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS")
     35 ..S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  I 'OCXEXF(OCXSUB) D
     36 ...S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB
     37 ...S OCXSUB="" F  S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB)  D
     38 ....S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB))
     39 ..S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  D
     40 ...D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F")
     41 ..D APPEND^OCXOCMP8(OCXRN,"$")
     42 ..S OCXRN=OCXRN+1 D GETHDR(OCXRN)
     43 ..;
     44 .D APPEND^OCXOCMP8(OCXRN,OCXD0,"C",OCXLLAB)
     45 .I ($E(OCXLLAB,1,2)="EL") D
     46 ..S ^OCXS(860.3,"APGM",(+$E(OCXLLAB,3,$L(OCXLLAB))),(OCXLLAB_U_$$RNAM(OCXRN)))=""
     47 .S $P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,2)=$$RNAM(OCXRN)
     48 .Q:'OCXLAST
     49 .K OCXEXF S OCXEXF=""
     50 .I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS")
     51 .S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  I 'OCXEXF(OCXSUB) D
     52 ..S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB
     53 ..S OCXSUB="" F  S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB)  D
     54 ...S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB))
     55 .S OCXSUB="" F  S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB)  D
     56 ..D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F")
     57 .D APPEND^OCXOCMP8(OCXRN,"$")
     58 ;
     59 W:'$G(OCXAUTO) !,?5,"Resolve Routine Line Tags..."
     60 S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0  D  Q:OCXWARN
     61 .I '$G(OCXAUTO) W:($X>60) ! W "."
     62 .N TEXT,RTN,TEMP,ALT,LABL,OBJ,PIEC
     63 .S RTN=$$RNAM(OCXD0)
     64 .K TEMP M TEMP=^TMP("OCXCMP",$J,"D CODE",OCXD0)
     65 .S OCXD1=0 F OCXOFF=0:1 S OCXD1=$O(TEMP(OCXD1)) Q:'OCXD1  D  Q:OCXWARN
     66 ..N TEXT,PIEC
     67 ..S TEXT=TEMP(OCXD1,0) Q:'(TEXT["||")
     68 ..;
     69 ..F PIEC=2:2:$L(TEXT,"||") D  Q:OCXWARN
     70 ...S LABL=$P(TEXT,"||",PIEC)
     71 ...I ($E(LABL,1,5)="LINE:") D  I 1
     72 ....S LABL=$G(^TMP("OCXCMP",$J,"LINE",+$P(LABL,":",2)))
     73 ....I '$L(LABL) D WARN^OCXOCMPV("Line Label not found: "_$P(TEXT,"|",2),$P($T(+1)," ",1)) Q
     74 ....S:($P(LABL,"^",2)=RTN) LABL=$P(LABL,"^",1)
     75 ...;
     76 ...E  I ($E(LABL,1,5)="LNTAG") D  I 1
     77 ....N D0,CNT
     78 ....S D0=OCXD1 F CNT=1:1 S D0=$O(TEMP(D0),-1)  Q:$L($P(TEMP(D0,0)," ",1))
     79 ....S LABL=$P(TEMP(D0,0)," ",1) S:(LABL["(") LABL=$P(LABL,"(",1)
     80 ....S LABL="(+$P($H,"","",2))_""<"_LABL_"+"_CNT_U_RTN_">"""
     81 ...;
     82 ...E  D WARN^OCXOCMPV("Unknown Compiler directive: "_LABL,$P($T(+1)," ",1)) Q
     83 ...;
     84 ...S $P(TEXT,"||",PIEC)=LABL
     85 ..;
     86 ..F  Q:'(TEXT["||")  S TEXT=$P(TEXT,"||",1)_$P(TEXT,"||",2,999)
     87 ..S TEMP(OCXD1,0)=TEXT
     88 .;
     89 .K ^TMP("OCXCMP",$J,"D CODE",OCXD0)
     90 .M ^TMP("OCXCMP",$J,"D CODE",OCXD0)=TEMP
     91 ;
     92 Q:OCXWARN 1
     93 W:'$G(OCXAUTO) !,?5,"Generate Subroutine and Call documentation..."
     94 S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0  D CALL^OCXOCMPT(OCXD0)
     95 ;
     96 W:'$G(OCXAUTO) !!,?5,"Delete Old OCXOZ* Routines..."
     97 S OCXRTEST=^%ZOSF("TEST"),OCXSAVE=^%ZOSF("SAVE"),OCXDEL=^%ZOSF("DEL")
     98 F OCXRN=1:1:1290 D
     99 .I '$G(OCXAUTO) W:($X>60) ! W:'(OCXRN#100) "."
     100 .S X=$$RNAM(OCXRN) X OCXRTEST I  X OCXDEL W:'$G(OCXAUTO) "!"
     101 ;
     102 W:'$G(OCXAUTO) !,?5,"File New OCXOZ* routines..."
     103 S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1
     104 F  S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0  D  Q:OCXWARN
     105 .I '$G(OCXAUTO) W:($X>60) ! W "."
     106 .D FILE^OCXOCMP8(OCXD0)
     107 S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1  D FILE^OCXOCMP8(OCXD0)
     108 ;
     109 Q OCXWARN
     110 ;
     111GETHDR(RNUM) ;
     112 ;
     113 N OCXREC,D0,EFC,OCXEFF,PIEC,TEXT
     114 S OCXREC(1,0)=$$RNAM(RNUM)_" ;SLC/RJS,CLA - Order Check Scan ;"_$$NOW
     115 S OCXREC(2,0)=$T(+2)
     116 S OCXREC(3,0)=$T(+3)
     117 S OCXREC(4,0)=" ;"
     118 S OCXREC(5,0)=" ; ***************************************************************"
     119 S OCXREC(6,0)=" ; ** Warning: This routine is automatically generated by the   **"
     120 S OCXREC(7,0)=" ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **"
     121 S OCXREC(8,0)=" ; ** will be lost the next time the rule compiler executes.    **"
     122 S OCXREC(9,0)=" ; ***************************************************************"
     123 S OCXREC(10,0)=" ;"
     124 I (RNUM=1) D
     125 .S OCXREC(11,0)=" ;    compiled code line length: "_OCXCLL
     126 .S OCXREC(12,0)=" ;        compiled routine size: "_OCXCRS
     127 .S OCXREC(13,0)=" ; triggered rule ignore period: "_OCXTSPI
     128 .S OCXREC(14,0)=" ;"
     129 .S OCXREC(15,0)=" ;   Program Execution Trace Mode: "_$S($G(OCXTRACE):" ON",1:"OFF")
     130 .S OCXREC(16,0)=" ;" ; " ;    Elapsed time logging: "_$S($G(OCXTLOG):" ON",1:"OFF")
     131 .S OCXREC(17,0)=" ;               Raw Data Logging: "_$S($G(OCXDLOG):(" ON  Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF")
     132 .S OCXREC(18,0)=" ; Compiler mode: "_$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):" ON",1:"OFF")
     133 .S OCXREC(19,0)=" ;   Compiled by: "_$P($G(^VA(200,+$G(DUZ),0)),U,1)_"  (DUZ="_(+$G(DUZ))_")"
     134 .S OCXREC(20,0)=" Q"
     135 .S OCXREC(21,0)=" ;"
     136 ;
     137 E  D
     138 .S OCXREC(11,0)=" Q"
     139 .S OCXREC(12,0)=" ;"
     140 ;
     141 M ^TMP("OCXCMP",$J,"D CODE",RNUM)=OCXREC
     142 Q
     143 ;
     144RNAM(X) ;
     145 N CHAR
     146 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
     147 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1))
     148 ;
     149TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y
     150 ;
     151NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y
     152 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m

    r613 r623  
    1 OCXOCMP8        ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;10/29/98  12:37
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         Q
    6 FILE(RNUM)      ;
    7         ;
    8         W:'$G(OCXAUTO) !,$$RNAM(RNUM)
    9         N DIE,XCN,X
    10         S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM)
    11         X ^%ZOSF("SAVE")
    12         Q
    13         ;
    14 APPEND(DSUB,CSUB,SRC,LABEL)     ;
    15         ;
    16         N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC
    17         S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")"
    18         I (CSUB="$") D  Q
    19         .S OCXNEXT=$O(@GLD@(" "),-1)+1
    20         .S @GLD@(OCXNEXT,0)="$"
    21         .S OCXNEXT=$O(@GLD@(" "),-1)+1
    22         .S @GLD@(OCXNEXT,0)=""
    23         ;
    24         I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1)
    25         I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB)
    26         S OCXNDX=0 F  S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX  D
    27         .S OCXNEXT=$O(@GLD@(" "),-1)+1
    28         .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0)
    29         M @GLD@("CALLS")=GLC("CALLS")
    30         S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE"))
    31         Q
    32         ;
    33 SIZE(DSUB,CSUB) ;
    34         ;
    35         N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC
    36         N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT
    37         ;
    38         S (SIZEC,SIZED,SIZEF)=0
    39         K OCXEFF,OCXEFC,OCXEFD
    40         S (OCXEFF,OCXEFC,OCXEFD)=""
    41         ;
    42         I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D
    43         .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D  Q
    44         ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")
    45         ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D
    46         ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")
    47         .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB)
    48         .S D0=0 F  S D0=$O(OCXREC(D0)) Q:'D0  D
    49         ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT)
    50         ..Q:'(TEXT["$$")
    51         ..F PIEC=2:1:$L(TEXT,"$$") D
    52         ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1)
    53         ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^")  Q:'$L(EFC)
    54         ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D  Q
    55         ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q
    56         ...S OCXEFC(EFC)=""
    57         .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION
    58         .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC
    59         .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC
    60         ;
    61         I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D
    62         .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D  Q
    63         ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")
    64         ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D
    65         ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")
    66         ;
    67         K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD
    68         ;
    69         I $D(OCXEFF) S EFC="" F  S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC)  I 'OCXEFF(EFC) D
    70         .K OCXTEMP
    71         .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")
    72         .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")
    73         .S OCXEFF(EFC)=OCXTEMP("SIZE")
    74         .Q:'$D(OCXTEMP("CALLS"))
    75         .S EFC="" F  S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC)  S OCXEFF(EFC)=+$G(OCXEFF(EFC))
    76         ;
    77         I $D(OCXEFF) S EFC="" F  S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC)  S SIZEF=SIZEF+OCXEFF(EFC)
    78         ;
    79         Q $G(SIZEC)+$G(SIZED)+$G(SIZEF)
    80         ;
    81 RNAM(X) ;
    82         N CHAR
    83         S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    84         Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1))
    85         ;
    86 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y
    87         ;
    88 NOW()   N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y
    89         ;
     1OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;6:55 PM  24 Jan 2008
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997;Build 2
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; Modified from FOIA VISTA,
     6 ; Copyright (C) 2007 WorldVistA
     7 ;
     8 ; This program is free software; you can redistribute it and/or modify
     9 ; it under the terms of the GNU General Public License as published by
     10 ; the Free Software Foundation; either version 2 of the License, or
     11 ; (at your option) any later version.
     12 ;
     13 Q
     14FILE(RNUM) ;
     15 ;
     16 W:'$G(OCXAUTO) !,$$RNAM(RNUM)
     17 N DIE,XCN,X
     18 S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM)
     19 X ^%ZOSF("SAVE")
     20 ;
     21 ; WVEHR/SO 01/24/08 ;Commented out next 2 lines
     22 ; W:'$G(OCXAUTO) "  ...",XCM," lines filed."
     23 ; S OCXLCNT=$G(OCXLCNT)+XCM
     24 ;
     25 Q
     26 ;
     27APPEND(DSUB,CSUB,SRC,LABEL) ;
     28 ;
     29 N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC
     30 S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")"
     31 I (CSUB="$") D  Q
     32 .S OCXNEXT=$O(@GLD@(" "),-1)+1
     33 .S @GLD@(OCXNEXT,0)="$"
     34 .S OCXNEXT=$O(@GLD@(" "),-1)+1
     35 .S @GLD@(OCXNEXT,0)=""
     36 ;
     37 I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1)
     38 I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB)
     39 S OCXNDX=0 F  S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX  D
     40 .S OCXNEXT=$O(@GLD@(" "),-1)+1
     41 .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0)
     42 M @GLD@("CALLS")=GLC("CALLS")
     43 S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE"))
     44 Q
     45 ;
     46SIZE(DSUB,CSUB) ;
     47 ;
     48 N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC
     49 N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT
     50 ;
     51 S (SIZEC,SIZED,SIZEF)=0
     52 K OCXEFF,OCXEFC,OCXEFD
     53 S (OCXEFF,OCXEFC,OCXEFD)=""
     54 ;
     55 I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D
     56 .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D  Q
     57 ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")
     58 ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D
     59 ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")
     60 .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB)
     61 .S D0=0 F  S D0=$O(OCXREC(D0)) Q:'D0  D
     62 ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT)
     63 ..Q:'(TEXT["$$")
     64 ..F PIEC=2:1:$L(TEXT,"$$") D
     65 ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1)
     66 ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^")  Q:'$L(EFC)
     67 ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D  Q
     68 ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q
     69 ...S OCXEFC(EFC)=""
     70 .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION
     71 .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC
     72 .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC
     73 ;
     74 I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D
     75 .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D  Q
     76 ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")
     77 ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D
     78 ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")
     79 ;
     80 K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD
     81 ;
     82 I $D(OCXEFF) S EFC="" F  S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC)  I 'OCXEFF(EFC) D
     83 .K OCXTEMP
     84 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")
     85 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")
     86 .S OCXEFF(EFC)=OCXTEMP("SIZE")
     87 .Q:'$D(OCXTEMP("CALLS"))
     88 .S EFC="" F  S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC)  S OCXEFF(EFC)=+$G(OCXEFF(EFC))
     89 ;
     90 I $D(OCXEFF) S EFC="" F  S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC)  S SIZEF=SIZEF+OCXEFF(EFC)
     91 ;
     92 Q $G(SIZEC)+$G(SIZED)+$G(SIZEF)
     93 ;
     94RNAM(X) ;
     95 N CHAR
     96 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
     97 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1))
     98 ;
     99TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y
     100 ;
     101NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y
     102 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPV.m

    r613 r623  
    1 OCXOCMPV        ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules  cont...) ;1/05/04  14:09
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 MAN     ;
    6         I '$D(DUZ) W !!,"DUZ not defined." Q
    7         N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXOETIM,OCXAUTO,OCXERRM,OCXTSPI
    8         S OCXWARN=0,OCXOETIM=$H
    9         K ^TMP("OCXCMP",$J)
    10         S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    11         ;
    12         ;  Compiler Constants
    13         ;
    14         S OCXCLL=200      ; compiled code line length
    15         S OCXCRS=4000     ; compiled routine size
    16         S OCXTSPI=300     ; Duplicate triggered Rule message "ignore period" in seconds
    17         ;
    18         S OCXTRACE=0,OCXTLOG=0,OCXDLOG=0,OCXAUTO=0,OCXERRM=""
    19         ;
    20         S OCXTRACE=$$READ("Y","Want to enable Compiled Routine Execution Display ","NO") Q:(OCXTRACE[U)
    21         S OCXDLOG=$$READ("Y","Want to enable Logging of incoming raw data ","NO") Q:(OCXDLOG[U)
    22         I OCXDLOG S OCXDLOG=$$READ("N^1:20","Number of days to keep raw data ","3") Q:(OCXDLOG[U)
    23         I OCXDLOG W !!,"*** Note: The raw data log will only hold 200,000 entries. *****",!
    24         I 0 I OCXDLOG S OCXTLOG=$$READ("Y","Want to enable Elapsed Time Logging ","YES") Q:(OCXTLOG[U)
    25         ;
    26         Q:'$$READ("Y","Are you sure you want to recompile the Expert System routines ","NO")
    27         ;
    28         D SETFLAG
    29         L +^OCXD(861,1):5 E  D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked.") Q
    30         D RUN^OCXOCMP,BULL(DUZ),KILLFLAG
    31         L -^OCXD(861,1)
    32         ;
    33         ;K ^TMP("OCXCMP",$J)
    34         ;
    35         Q
    36         ;
    37 MESG(OCXX)      ;
    38         I '$G(OCXAUTO) W !!,OCXX
    39         I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
    40         Q
    41         ;
    42 ERMESG(OCXX)    ;
    43         N OCXY S OCXY=OCXX
    44         I '$G(OCXAUTO) W !!,OCXX
    45         I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
    46         S OCXERRM=OCXY
    47         Q
    48         ;
    49 WARN(X,FILE,D0,RLINE)   ;
    50         ;
    51         Q:$G(OCXWARN)
    52         ;
    53         S OCXWARN=1
    54         ;
    55         I $G(OCXAUTO) D  Q
    56         .D MESG(" Error... "_X)
    57         .D MESG(" Error...  File:"_(+$G(FILE)))
    58         .D MESG(" Error... Index:"_(+$G(D0)))
    59         .D MESG(" Error... Order Check Routine Compile Aborted.")
    60         ;
    61         S OCXWARN=$G(OCXWARN)+1
    62         N OCXSP,OCXST,OCXTXT,OCXLEN,OCXZZZ,OCXCNT
    63         S OCXLEN=60,OCXTXT="Compiler Warning # "_OCXWARN
    64         I ($D(X)>2) S OCXCNT=0 F  S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT  D
    65         .I ($L(X(OCXCNT))>OCXLEN),($L(X(OCXCNT))<80) S OCXLEN=$L(X(OCXCNT))
    66         S (OCXSP,OCXST)="",$P(OCXST,"*",150)="*",$P(OCXSP," ",150)=" "
    67         W !!
    68         W !,$E(OCXST,1,OCXLEN+6)
    69         W !,"**",$E(OCXSP,1,OCXLEN+2),"**"
    70         W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **"
    71         W:$L($G(RLINE)) !,"** ",RLINE,$E(OCXSP,$L(RLINE),OCXLEN-1)," **"
    72         W !,"**",$E(OCXSP,1,OCXLEN+2),"**"
    73         S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860
    74         I $G(FILE),$G(D0),$D(@OCXGL@(FILE,D0,0)) D
    75         .S OCXTXT=$P(@OCXGL@(FILE,0),U,1)
    76         .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **"
    77         .S OCXTXT="   "_$P(@OCXGL@(FILE,D0,0),U,1)
    78         .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **"
    79         W !,"**",$E(OCXSP,1,OCXLEN+2),"**"
    80         I ($D(X)#2) D
    81         .W !,"** " F OCXCNT=1:1:$L(X," ") D
    82         ..I (($X+$L($P(X," ",OCXCNT)))>OCXLEN) W $E(OCXSP,$X,OCXLEN+2)," **",!,"** "
    83         ..W $P(X," ",OCXCNT)," "
    84         .W $E(OCXSP,$X,OCXLEN+2)," **"
    85         I ($D(X)>2) S OCXCNT=0 F  S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT  D
    86         .W !,"** ",X(OCXCNT),$E(OCXSP,$X,OCXLEN+2)," **"
    87         W !,$E(OCXST,1,OCXLEN+6)
    88         W !!!,"Press <Return> to continue... " R OCXZZZ:DTIME
    89         Q
    90         K D0
    91         ;
    92 READ(OCXZ0,OCXZA,OCXZB,OCXZL)   ;
    93         N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    94         Q:'$L($G(OCXZ0)) U
    95         S DIR(0)=OCXZ0
    96         S:$L($G(OCXZA)) DIR("A")=OCXZA
    97         S:$L($G(OCXZB)) DIR("B")=OCXZB
    98         F OCXLINE=1:1:($G(OCXZL)-1) W !
    99         D ^DIR
    100         I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    101         Q Y
    102         ;
    103         Q
    104         ;
    105 DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y
    106         Q
    107         ;
    108 CNT(X)  ;
    109         ;
    110         N CNT,D0
    111         S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0
    112         W !!,?10,X,"  ",CNT
    113         Q CNT
    114         ;
    115 AUTO    ;
    116         N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXTSPI
    117         S OCXWARN=0,OCXOETIM=$H
    118         K ^TMP("OCXCMP",$J)
    119         S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    120         ;
    121         ;  Compiler Constants
    122         ;
    123         S OCXCLL=200      ; compiled code line length
    124         S OCXCRS=8000     ; compiled routine size
    125         S OCXTSPI=300     ; Duplicate triggered Rule message "ignore period" in seconds
    126         ;
    127         S OCXTRACE=0      ; Program Execution Trace Mode (OFF)
    128         S OCXTLOG=0       ; Elapsed time logging (OFF)
    129         S OCXDLOG=0       ; Raw Data Logging (OFF)
    130         S OCXAUTO=1       ; Compile in the Background Mode (ON)
    131         ;
    132         D SETFLAG
    133         L +^OCXD(861,1):5 E  D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked."),BULL(DUZ),KILLFLAG Q
    134         D RUN^OCXOCMP,BULL(DUZ),KILLFLAG
    135         L -^OCXD(861,1)
    136         ;
    137         K ^TMP("OCXCMP",$J)
    138         ;
    139         Q
    140         ;
    141 BULL(OCXDUZ)    ;
    142         I $L($T(^XMB)) D
    143         .;
    144         .N XMB,XMDUZ,XMY,OCXTIME
    145         .S OCXTIME=$H-OCXOETIM*86400
    146         .S OCXTIME=OCXTIME+($P($H,",",2)-$P(OCXOETIM,",",2))
    147         .S XMB="OCX COMPILER RUN"
    148         .S XMB(1)=$P($T(+3),";;",3)
    149         .S XMB(2)=$$CONV($$DATE)
    150         .S XMB(3)=""
    151         .S:$G(OCXDUZ) XMB(3)="["_OCXDUZ_"]  "_$P($G(^VA(200,OCXDUZ,0)),U,1)
    152         .S XMB(4)=(OCXTIME\60)_" minutes "_(OCXTIME#60)_" seconds "
    153         .S XMB(5)=$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):"Automatic Mode",1:"Interactive Mode")
    154         .S XMB(6)=$S($G(OCXTRACE):" ON",1:"OFF")
    155         .S XMB(7)=" " ; $S($G(OCXTLOG):" ON",1:"OFF")
    156         .S XMB(8)=$S($G(OCXDLOG):(" ON  Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF")
    157         .S XMB(9)="No longer tracked" ; $S($G(OCXLCNT):OCXLCNT,1:"Zero")
    158         .S XMB(10)=$G(OCXERRM)
    159         .S XMB(11)=$S($L($G(OCXERRM)):"ABORTED",1:"has completed normally")
    160         .S XMY("G.OCX DEVELOPERS@ISC-SLC.VA.GOV")=""
    161         .S XMY("G.OCX DEVELOPERS")=""
    162         .S XMY(OCXDUZ)=""
    163         .S XMDUZ=.5
    164         .S XMDT="N"
    165         .D ^XMB
    166         ;
    167         Q
    168         ;
    169 DATE()  N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y
    170         ;
    171 CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99)
    172         ;
    173 SETFLAG ;
    174         I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES"
    175         S $P(^OCXD(861,1,0),U,3)=$H
    176         Q
    177         ;
    178 KILLFLAG        ;
    179         ;
    180         I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES"
    181         S $P(^OCXD(861,1,0),U,3)=""
    182         Q
    183         ;
    184 QUE(OCXADD)     ;
    185         ;
    186         N ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTRTN,ZTSAVE,ZTSK,ZTUCI
    187         N OCXDUZ
    188         ;
    189         S ZTDTH=$P($H,",",2)+OCXADD,OCXADD=0
    190         I (ZTDTH>86400) S ZTDTH=(86400-ZTDTH),OCXADD=1
    191         S ZTDTH=($H+OCXADD)_","_ZTDTH
    192         S OCXDUZ=$G(DUZ)
    193         S ZTIO="",ZTRTN="TASK^OCXOCMPV",ZTDESC="Queued Compiler: "_$P($T(+3),";;",2)
    194         K ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE
    195         S ZTSAVE("OCXDUZ")=""
    196         ;
    197         D ^%ZTLOAD
    198         ;
    199         Q
    200         ;
    201 TASK    ;
    202         ;
    203         N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXTSPI
    204         S OCXWARN=0,OCXOETIM=$H
    205         K ^TMP("OCXCMP",$J)
    206         S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    207         ;
    208         ;  Compiler Constants
    209         ;
    210         S OCXCLL=200      ; compiled code line length
    211         S OCXCRS=8000     ; compiled routine size
    212         S OCXTSPI=300     ; Duplicate triggered Rule message "ignore period" in seconds
    213         ;
    214         S OCXDATA="0^0^0"
    215         I $L($T(CDATA^OCXOZ01)) S OCXDATA=$$CDATA^OCXOZ01
    216         ;
    217         S OCXTRACE=$P(OCXDATA,U,1),OCXTLOG=$P(OCXDATA,U,2),OCXDLOG=$P(OCXDATA,U,3)
    218         ;
    219         S OCXAUTO=2       ; Compile in the Background Mode (ON QUEUED)
    220         ;
    221         D SETFLAG
    222         L +^OCXD(861,1):5 E  D QUE^OCXOCMPV(300),ERMESG("Run rescheduled. Another compiler run has ^OCXD(861,1) locked."),BULL(OCXDUZ),KILLFLAG Q
    223         D RUN^OCXOCMP,BULL(OCXDUZ),KILLFLAG
    224         L -^OCXD(861,1)
    225         ;
    226         K ^TMP("OCXCMP",$J)
    227         ;
    228         I $G(ZTSK) D KILL^%ZTLOAD
    229         ;
    230         Q
    231         ;
     1OCXOCMPV ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules  cont...) ;1/05/04  14:09
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5MAN ;
     6 I '$D(DUZ) W !!,"DUZ not defined." Q
     7 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXOETIM,OCXLCNT,OCXAUTO,OCXERRM,OCXTSPI
     8 S OCXWARN=0,OCXOETIM=$H
     9 K ^TMP("OCXCMP",$J)
     10 S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     11 ;
     12 ;  Compiler Constants
     13 ;
     14 S OCXCLL=200      ; compiled code line length
     15 S OCXCRS=4000     ; compiled routine size
     16 S OCXTSPI=300     ; Duplicate triggered Rule message "ignore period" in seconds
     17 ;
     18 S OCXTRACE=0,OCXTLOG=0,OCXDLOG=0,OCXAUTO=0,OCXERRM=""
     19 ;
     20 S OCXTRACE=$$READ("Y","Want to enable Compiled Routine Execution Display ","NO") Q:(OCXTRACE[U)
     21 S OCXDLOG=$$READ("Y","Want to enable Logging of incoming raw data ","NO") Q:(OCXDLOG[U)
     22 I OCXDLOG S OCXDLOG=$$READ("N^1:20","Number of days to keep raw data ","3") Q:(OCXDLOG[U)
     23 I OCXDLOG W !!,"*** Note: The raw data log will only hold 200,000 entries. *****",!
     24 I 0 I OCXDLOG S OCXTLOG=$$READ("Y","Want to enable Elapsed Time Logging ","YES") Q:(OCXTLOG[U)
     25 ;
     26 Q:'$$READ("Y","Are you sure you want to recompile the Expert System routines ","NO")
     27 ;
     28 D SETFLAG
     29 L +^OCXD(861,1):5 E  D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked.") Q
     30 D RUN^OCXOCMP,BULL(DUZ),KILLFLAG
     31 L -^OCXD(861,1)
     32 ;
     33 ;K ^TMP("OCXCMP",$J)
     34 ;
     35 Q
     36 ;
     37MESG(OCXX) ;
     38 I '$G(OCXAUTO) W !!,OCXX
     39 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
     40 Q
     41 ;
     42ERMESG(OCXX) ;
     43 N OCXY S OCXY=OCXX
     44 I '$G(OCXAUTO) W !!,OCXX
     45 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
     46 S OCXERRM=OCXY
     47 Q
     48 ;
     49WARN(X,FILE,D0,RLINE) ;
     50 ;
     51 Q:$G(OCXWARN)
     52 ;
     53 S OCXWARN=1
     54 ;
     55 I $G(OCXAUTO) D  Q
     56 .D MESG(" Error... "_X)
     57 .D MESG(" Error...  File:"_(+$G(FILE)))
     58 .D MESG(" Error... Index:"_(+$G(D0)))
     59 .D MESG(" Error... Order Check Routine Compile Aborted.")
     60 ;
     61 S OCXWARN=$G(OCXWARN)+1
     62 N OCXSP,OCXST,OCXTXT,OCXLEN,OCXZZZ,OCXCNT
     63 S OCXLEN=60,OCXTXT="Compiler Warning # "_OCXWARN
     64 I ($D(X)>2) S OCXCNT=0 F  S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT  D
     65 .I ($L(X(OCXCNT))>OCXLEN),($L(X(OCXCNT))<80) S OCXLEN=$L(X(OCXCNT))
     66 S (OCXSP,OCXST)="",$P(OCXST,"*",150)="*",$P(OCXSP," ",150)=" "
     67 W !!
     68 W !,$E(OCXST,1,OCXLEN+6)
     69 W !,"**",$E(OCXSP,1,OCXLEN+2),"**"
     70 W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **"
     71 W:$L($G(RLINE)) !,"** ",RLINE,$E(OCXSP,$L(RLINE),OCXLEN-1)," **"
     72 W !,"**",$E(OCXSP,1,OCXLEN+2),"**"
     73 S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860
     74 I $G(FILE),$G(D0),$D(@OCXGL@(FILE,D0,0)) D
     75 .S OCXTXT=$P(@OCXGL@(FILE,0),U,1)
     76 .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **"
     77 .S OCXTXT="   "_$P(@OCXGL@(FILE,D0,0),U,1)
     78 .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **"
     79 W !,"**",$E(OCXSP,1,OCXLEN+2),"**"
     80 I ($D(X)#2) D
     81 .W !,"** " F OCXCNT=1:1:$L(X," ") D
     82 ..I (($X+$L($P(X," ",OCXCNT)))>OCXLEN) W $E(OCXSP,$X,OCXLEN+2)," **",!,"** "
     83 ..W $P(X," ",OCXCNT)," "
     84 .W $E(OCXSP,$X,OCXLEN+2)," **"
     85 I ($D(X)>2) S OCXCNT=0 F  S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT  D
     86 .W !,"** ",X(OCXCNT),$E(OCXSP,$X,OCXLEN+2)," **"
     87 W !,$E(OCXST,1,OCXLEN+6)
     88 W !!!,"Press <Return> to continue... " R OCXZZZ:DTIME
     89 Q
     90 K D0
     91 ;
     92READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
     93 N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     94 Q:'$L($G(OCXZ0)) U
     95 S DIR(0)=OCXZ0
     96 S:$L($G(OCXZA)) DIR("A")=OCXZA
     97 S:$L($G(OCXZB)) DIR("B")=OCXZB
     98 F OCXLINE=1:1:($G(OCXZL)-1) W !
     99 D ^DIR
     100 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     101 Q Y
     102 ;
     103 Q
     104 ;
     105DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y
     106 Q
     107 ;
     108CNT(X) ;
     109 ;
     110 N CNT,D0
     111 S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0
     112 W !!,?10,X,"  ",CNT
     113 Q CNT
     114 ;
     115AUTO ;
     116 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXLCNT,OCXTSPI
     117 S OCXWARN=0,OCXOETIM=$H
     118 K ^TMP("OCXCMP",$J)
     119 S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     120 ;
     121 ;  Compiler Constants
     122 ;
     123 S OCXCLL=200      ; compiled code line length
     124 S OCXCRS=8000     ; compiled routine size
     125 S OCXTSPI=300     ; Duplicate triggered Rule message "ignore period" in seconds
     126 ;
     127 S OCXTRACE=0      ; Program Execution Trace Mode (OFF)
     128 S OCXTLOG=0       ; Elapsed time logging (OFF)
     129 S OCXDLOG=0       ; Raw Data Logging (OFF)
     130 S OCXAUTO=1       ; Compile in the Background Mode (ON)
     131 ;
     132 D SETFLAG
     133 L +^OCXD(861,1):5 E  D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked."),BULL(DUZ),KILLFLAG Q
     134 D RUN^OCXOCMP,BULL(DUZ),KILLFLAG
     135 L -^OCXD(861,1)
     136 ;
     137 K ^TMP("OCXCMP",$J)
     138 ;
     139 Q
     140 ;
     141BULL(OCXDUZ) ;
     142 I $L($T(^XMB)) D
     143 .;
     144 .N XMB,XMDUZ,XMY,OCXTIME
     145 .S OCXTIME=$H-OCXOETIM*86400
     146 .S OCXTIME=OCXTIME+($P($H,",",2)-$P(OCXOETIM,",",2))
     147 .S XMB="OCX COMPILER RUN"
     148 .S XMB(1)=$P($T(+3),";;",3)
     149 .S XMB(2)=$$CONV($$DATE)
     150 .S XMB(3)=""
     151 .S:$G(OCXDUZ) XMB(3)="["_OCXDUZ_"]  "_$P($G(^VA(200,OCXDUZ,0)),U,1)
     152 .S XMB(4)=(OCXTIME\60)_" minutes "_(OCXTIME#60)_" seconds "
     153 .S XMB(5)=$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):"Automatic Mode",1:"Interactive Mode")
     154 .S XMB(6)=$S($G(OCXTRACE):" ON",1:"OFF")
     155 .S XMB(7)=" " ; $S($G(OCXTLOG):" ON",1:"OFF")
     156 .S XMB(8)=$S($G(OCXDLOG):(" ON  Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF")
     157 .S XMB(9)=$S($G(OCXLCNT):OCXLCNT,1:"Zero")
     158 .S XMB(10)=$G(OCXERRM)
     159 .S XMB(11)=$S($L($G(OCXERRM)):"ABORTED",1:"has completed normally")
     160 .S XMY("G.OCX DEVELOPERS@ISC-SLC.VA.GOV")=""
     161 .S XMY("G.OCX DEVELOPERS")=""
     162 .S XMY(OCXDUZ)=""
     163 .S XMDUZ=.5
     164 .S XMDT="N"
     165 .D ^XMB
     166 ;
     167 Q
     168 ;
     169DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y
     170 ;
     171CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99)
     172 ;
     173SETFLAG ;
     174 I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES"
     175 S $P(^OCXD(861,1,0),U,3)=$H
     176 Q
     177 ;
     178KILLFLAG ;
     179 ;
     180 I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES"
     181 S $P(^OCXD(861,1,0),U,3)=""
     182 Q
     183 ;
     184QUE(OCXADD) ;
     185 ;
     186 N ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTRTN,ZTSAVE,ZTSK,ZTUCI
     187 N OCXDUZ
     188 ;
     189 S ZTDTH=$P($H,",",2)+OCXADD,OCXADD=0
     190 I (ZTDTH>86400) S ZTDTH=(86400-ZTDTH),OCXADD=1
     191 S ZTDTH=($H+OCXADD)_","_ZTDTH
     192 S OCXDUZ=$G(DUZ)
     193 S ZTIO="",ZTRTN="TASK^OCXOCMPV",ZTDESC="Queued Compiler: "_$P($T(+3),";;",2)
     194 K ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE
     195 S ZTSAVE("OCXDUZ")=""
     196 ;
     197 D ^%ZTLOAD
     198 ;
     199 Q
     200 ;
     201TASK ;
     202 ;
     203 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXLCNT,OCXTSPI
     204 S OCXWARN=0,OCXOETIM=$H
     205 K ^TMP("OCXCMP",$J)
     206 S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     207 ;
     208 ;  Compiler Constants
     209 ;
     210 S OCXCLL=200      ; compiled code line length
     211 S OCXCRS=8000     ; compiled routine size
     212 S OCXTSPI=300     ; Duplicate triggered Rule message "ignore period" in seconds
     213 ;
     214 S OCXDATA="0^0^0"
     215 I $L($T(CDATA^OCXOZ01)) S OCXDATA=$$CDATA^OCXOZ01
     216 ;
     217 S OCXTRACE=$P(OCXDATA,U,1),OCXTLOG=$P(OCXDATA,U,2),OCXDLOG=$P(OCXDATA,U,3)
     218 ;
     219 S OCXAUTO=2       ; Compile in the Background Mode (ON QUEUED)
     220 ;
     221 D SETFLAG
     222 L +^OCXD(861,1):5 E  D QUE^OCXOCMPV(300),ERMESG("Run rescheduled. Another compiler run has ^OCXD(861,1) locked."),BULL(OCXDUZ),KILLFLAG Q
     223 D RUN^OCXOCMP,BULL(OCXDUZ),KILLFLAG
     224 L -^OCXD(861,1)
     225 ;
     226 K ^TMP("OCXCMP",$J)
     227 ;
     228 I $G(ZTSK) D KILL^%ZTLOAD
     229 ;
     230 Q
     231 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m

    r613 r623  
    1 OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         ;    compiled code line length: 200
    12         ;        compiled routine size: 8000
    13         ; triggered rule ignore period: 300
    14         ;
    15         ;   Program Execution Trace Mode: OFF
    16         ;
    17         ;               Raw Data Logging: OFF
    18         ; Compiler mode:  ON
    19         ;   Compiled by: DEWAYNE,ROBERT  (DUZ=9)
    20         Q
    21         ;
    22 LOG()   ; Returns the number of days to keep the Raw Data Log or 0 if logging is disabled.
    23         ;  External Call.
    24         ;
    25         Q 0
    26         ;
    27 CDATA() ; Returns compiler flags, Execution TRACE ON/OFF, Time Logging ON/OFF, and Raw Data Logging ON/OFF
    28         ;  External Call.
    29         ;
    30         Q "0^0^0"
    31         ;
    32 UPDATE(DFN,OCXSRC,OUTMSG)       ; Main Entry point for evaluating Rules.
    33         ;  External Call.
    34         ;
    35         ;
    36         K ^TMP("OCXCHK",$J)
    37         S ^TMP("OCXCHK",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    38         N OCXOERR,OCXOCMSG,OCXNDX,OCXDF,OCXX,OCXTSPI
    39         S OCXTSPI=300
    40         Q:'$G(DFN)
    41         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D GETDF,SWAPOUT("OCXODATA",.OCXODATA)
    42         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D CHK1^OCXOZ02
    43         I ($G(OCXOSRC)="DGPM PATIENT MOVEMENT PROTOCOL") D CHK23^OCXOZ03
    44         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") D CHK58^OCXOZ05
    45         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D CHK95^OCXOZ06
    46         ;
    47         D SCAN
    48         ;
    49         I $O(OCXOCMSG("")) D
    50         .N OCXNDX1,OCXNDX2
    51         .S OCXNDX1=0 F  S OCXNDX1=$O(OCXOCMSG(OCXNDX1)) Q:'OCXNDX1  D
    52         ..S OCXNDX2=0 F  S OCXNDX2=$O(OUTMSG(OCXNDX2)) Q:'OCXNDX2  Q:(OUTMSG(OCXNDX2)=OCXOCMSG(OCXNDX1))
    53         ..Q:OCXNDX2  S OUTMSG($O(OUTMSG(999999),-1)+1)=OCXOCMSG(OCXNDX1)
    54         K ^TMP("OCXCHK",$J)
    55         ;
    56         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") K OCXDF D SWAPIN("OCXODATA",.OCXODATA)
    57         Q
    58         ;
    59 GETDF   ;This subroutine loads the OCXDF data field array from variables in the environment.
    60         ;  Called from UPDATE+9.
    61         ;
    62         Q:$G(OCXOERR)
    63         ;
    64         ;    Local GETDF Variables
    65         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    66         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    67         ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT)
    68         ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
    69         ; OCXDF(9) ----> Data Field: ORDER ST D/T (DATE/TIME)
    70         ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT)
    71         ; OCXDF(13) ---> Data Field: LAB COLLECTION D/T (DATE/TIME)
    72         ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
    73         ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT)
    74         ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
    75         ; OCXDF(24) ---> Data Field: ORDERABLE ITEM LOCAL TEXT (FREE TEXT)
    76         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    77         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    78         ; OCXDF(82) ---> Data Field: PHARMACY LOCAL ORDERABLE ITEM TEXT (FREE TEXT)
    79         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    80         ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC)
    81         ;
    82         ;      Local Extrinsic Functions
    83         ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT
    84         ;
    85         S OCXDF(1)=$P($G(OCXODATA("ORC",1)),"^",1)
    86         S OCXDF(2)=$P($G(OCXODATA("ORC",3)),"^",2)
    87         S OCXDF(5)=$P($P($G(OCXODATA("OBR",27)),"^",6),";",1)
    88         S OCXDF(6)=$P($G(OCXODATA("OBX",8)),"^",1)
    89         S OCXDF(9)=$$DT2INT($P($G(OCXODATA("ORC",15)),"^",1))
    90         S OCXDF(12)=$P($G(OCXODATA("OBX",5)),"^",1)
    91         S OCXDF(13)=$$DT2INT($P($G(OCXODATA("OBR",7)),"^",1))
    92         S OCXDF(15)=$P($G(OCXODATA("OBX",11)),"^",1)
    93         S OCXDF(21)=$P($G(OCXODATA("ORC",7)),"^",6)
    94         S OCXDF(23)=$P($G(OCXODATA("OBR",25)),"^",1)
    95         S OCXDF(24)=$P($G(OCXODATA("OBR",4)),"^",5)
    96         S OCXDF(34)=$P($G(OCXODATA("ORC",2)),"^",1)
    97         S OCXDF(37)=$G(OCXODATA("PID",3))
    98         S OCXDF(82)=$P($G(OCXODATA("RXO",1)),"^",5)
    99         S OCXDF(113)=$P($G(OCXODATA("OBX",3)),"^",4)
    100         S OCXDF(152)=$P($P($G(OCXODATA("OBR",15)),"^",4),";",1)
    101         Q
    102         ;
    103 SWAPOUT(NAME,ARRAY)     ;
    104         ;  Called from UPDATE+9.
    105         ;
    106         Q:$G(OCXOERR)
    107         ;
    108         Q:'$L(NAME)
    109         K ^TMP("OCXSWAP",$J,NAME)
    110         S ^TMP("OCXSWAP",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    111         M ^TMP("OCXSWAP",$J,NAME)=ARRAY
    112         K ARRAY
    113         Q
    114         ;
    115 SWAPIN(NAME,ARRAY)      ;
    116         ;  Called from UPDATE+24.
    117         ;
    118         Q:$G(OCXOERR)
    119         ;
    120         Q:'$L(NAME)
    121         K ARRAY
    122         M ARRAY=^TMP("OCXSWAP",$J,NAME)
    123         K ^TMP("OCXSWAP",$J,NAME)
    124         Q
    125         ;
    126 SCAN    ; Tests all Rules for Event/Elements that were found to be valid in the UPDATE subroutine.
    127         ;  Called from UPDATE+15.
    128         ;
    129         Q:$G(OCXOERR)
    130         ;
    131         ;
    132         N OCXD0,OCXRULE S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCHK",$J,DFN,OCXD0)) Q:'OCXD0  D
    133         .Q:'($G(^TMP("OCXCHK",$J,DFN,OCXD0))=1)
    134         .N OCXPGM S OCXPGM=$O(^OCXS(860.3,"APGM",OCXD0,"")) Q:'$L(OCXPGM)  X "I $L($T("_OCXPGM_"))" E  Q
    135         .D @OCXPGM
    136         .S ^TMP("OCXCHK",$J,DFN,OCXD0)=$G(^TMP("OCXCHK",$J,DFN,OCXD0))+10
    137         K ^TMP("OCXCHK",$J)
    138         Q
    139         ;
    140 TERM(OCXTERM,OCXLIST)   ; Local Term Lookup
    141         ;  Internal Call.
    142         ;
    143         Q:$G(OCXOERR)
    144         ;
    145         Q:'$L(OCXTERM) 0
    146         ;
    147         N FILE,IEN,LINE,LTERM,NTERM,TEXT S FILE=0 K OCXLIST
    148         F LINE=1:1:999 S TEXT=$T(TERM+LINE) Q:$P(TEXT,";",2)  I ($E(TEXT,2,3)=";;") D
    149         .S TEXT=$P(TEXT,";;",2)
    150         .S NTERM=$P(TEXT,U,1) Q:'$L(NTERM)  Q:'(OCXTERM=NTERM)
    151         .S FILE=$P(TEXT,U,2),IEN=$P(TEXT,U,3),LTERM=$P(TEXT,U,4)
    152         .S OCXLIST(IEN)=LTERM,OCXLIST("B",LTERM,IEN)=""
    153         ;
    154         Q FILE
    155         ;
    156         ;TERM DATA;
    157         ;1;
    158         ;
    159         Q
    160         ;
    161 DT2INT(OCXDT)   ;      This Local Extrinsic Function converts a date into an integer
    162         ; By taking the Years, Months, Days, Hours and Minutes converting
    163         ; Them into Seconds and then adding them all together into one big integer
    164         ;
    165         Q:'$L($G(OCXDT)) ""
    166         N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
    167         ;
    168         I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
    169         .N OCXHR,OCXMIN,OCXTIME
    170         .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
    171         .S:(OCXDT["Midnight") OCXHR=00
    172         .S:(OCXDT["PM") OCXHR=OCXHR+12
    173         .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
    174         ;
    175         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
    176         .N OCXMON
    177         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    178         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
    179         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
    180         ;
    181         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
    182         .N OCXMON
    183         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    184         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
    185         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
    186         ;
    187         I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
    188         .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
    189         .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
    190         ;
    191         I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
    192         ;
    193         I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
    194         ;
    195         I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
    196         ;
    197         Q OCXVAL
    198         ;
     1OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 ;    compiled code line length: 200
     12 ;        compiled routine size: 8000
     13 ; triggered rule ignore period: 300
     14 ;
     15 ;   Program Execution Trace Mode: OFF
     16 ;
     17 ;               Raw Data Logging: OFF
     18 ; Compiler mode:  ON
     19 ;   Compiled by: ORMSBY,SKIP  (DUZ=1)
     20 Q
     21 ;
     22LOG() ; Returns the number of days to keep the Raw Data Log or 0 if logging is disabled.
     23 ;  External Call.
     24 ;
     25 Q 0
     26 ;
     27CDATA() ; Returns compiler flags, Execution TRACE ON/OFF, Time Logging ON/OFF, and Raw Data Logging ON/OFF
     28 ;  External Call.
     29 ;
     30 Q "0^0^0"
     31 ;
     32UPDATE(DFN,OCXSRC,OUTMSG) ; Main Entry point for evaluating Rules.
     33 ;  External Call.
     34 ;
     35 ;
     36 K ^TMP("OCXCHK",$J)
     37 S ^TMP("OCXCHK",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     38 N OCXOERR,OCXOCMSG,OCXNDX,OCXDF,OCXX,OCXTSPI
     39 S OCXTSPI=300
     40 Q:'$G(DFN)
     41 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D GETDF,SWAPOUT("OCXODATA",.OCXODATA)
     42 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D CHK1^OCXOZ02
     43 I ($G(OCXOSRC)="DGPM PATIENT MOVEMENT PROTOCOL") D CHK23^OCXOZ03
     44 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") D CHK58^OCXOZ05
     45 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D CHK95^OCXOZ06
     46 ;
     47 D SCAN
     48 ;
     49 I $O(OCXOCMSG("")) D
     50 .N OCXNDX1,OCXNDX2
     51 .S OCXNDX1=0 F  S OCXNDX1=$O(OCXOCMSG(OCXNDX1)) Q:'OCXNDX1  D
     52 ..S OCXNDX2=0 F  S OCXNDX2=$O(OUTMSG(OCXNDX2)) Q:'OCXNDX2  Q:(OUTMSG(OCXNDX2)=OCXOCMSG(OCXNDX1))
     53 ..Q:OCXNDX2  S OUTMSG($O(OUTMSG(999999),-1)+1)=OCXOCMSG(OCXNDX1)
     54 K ^TMP("OCXCHK",$J)
     55 ;
     56 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") K OCXDF D SWAPIN("OCXODATA",.OCXODATA)
     57 Q
     58 ;
     59GETDF ;This subroutine loads the OCXDF data field array from variables in the environment.
     60 ;  Called from UPDATE+9.
     61 ;
     62 Q:$G(OCXOERR)
     63 ;
     64 ;    Local GETDF Variables
     65 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     66 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     67 ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT)
     68 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
     69 ; OCXDF(9) ----> Data Field: ORDER ST D/T (DATE/TIME)
     70 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT)
     71 ; OCXDF(13) ---> Data Field: LAB COLLECTION D/T (DATE/TIME)
     72 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
     73 ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT)
     74 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
     75 ; OCXDF(24) ---> Data Field: ORDERABLE ITEM LOCAL TEXT (FREE TEXT)
     76 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     77 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     78 ; OCXDF(82) ---> Data Field: PHARMACY LOCAL ORDERABLE ITEM TEXT (FREE TEXT)
     79 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     80 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC)
     81 ;
     82 ;      Local Extrinsic Functions
     83 ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT
     84 ;
     85 S OCXDF(1)=$P($G(OCXODATA("ORC",1)),"^",1)
     86 S OCXDF(2)=$P($G(OCXODATA("ORC",3)),"^",2)
     87 S OCXDF(5)=$P($P($G(OCXODATA("OBR",27)),"^",6),";",1)
     88 S OCXDF(6)=$P($G(OCXODATA("OBX",8)),"^",1)
     89 S OCXDF(9)=$$DT2INT($P($G(OCXODATA("ORC",15)),"^",1))
     90 S OCXDF(12)=$P($G(OCXODATA("OBX",5)),"^",1)
     91 S OCXDF(13)=$$DT2INT($P($G(OCXODATA("OBR",7)),"^",1))
     92 S OCXDF(15)=$P($G(OCXODATA("OBX",11)),"^",1)
     93 S OCXDF(21)=$P($G(OCXODATA("ORC",7)),"^",6)
     94 S OCXDF(23)=$P($G(OCXODATA("OBR",25)),"^",1)
     95 S OCXDF(24)=$P($G(OCXODATA("OBR",4)),"^",5)
     96 S OCXDF(34)=$P($G(OCXODATA("ORC",2)),"^",1)
     97 S OCXDF(37)=$G(OCXODATA("PID",3))
     98 S OCXDF(82)=$P($G(OCXODATA("RXO",1)),"^",5)
     99 S OCXDF(113)=$P($G(OCXODATA("OBX",3)),"^",4)
     100 S OCXDF(152)=$P($P($G(OCXODATA("OBR",15)),"^",4),";",1)
     101 Q
     102 ;
     103SWAPOUT(NAME,ARRAY) ;
     104 ;  Called from UPDATE+9.
     105 ;
     106 Q:$G(OCXOERR)
     107 ;
     108 Q:'$L(NAME)
     109 K ^TMP("OCXSWAP",$J,NAME)
     110 S ^TMP("OCXSWAP",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     111 M ^TMP("OCXSWAP",$J,NAME)=ARRAY
     112 K ARRAY
     113 Q
     114 ;
     115SWAPIN(NAME,ARRAY) ;
     116 ;  Called from UPDATE+24.
     117 ;
     118 Q:$G(OCXOERR)
     119 ;
     120 Q:'$L(NAME)
     121 K ARRAY
     122 M ARRAY=^TMP("OCXSWAP",$J,NAME)
     123 K ^TMP("OCXSWAP",$J,NAME)
     124 Q
     125 ;
     126SCAN ; Tests all Rules for Event/Elements that were found to be valid in the UPDATE subroutine.
     127 ;  Called from UPDATE+15.
     128 ;
     129 Q:$G(OCXOERR)
     130 ;
     131 ;
     132 N OCXD0,OCXRULE S OCXD0=0 F  S OCXD0=$O(^TMP("OCXCHK",$J,DFN,OCXD0)) Q:'OCXD0  D
     133 .Q:'($G(^TMP("OCXCHK",$J,DFN,OCXD0))=1)
     134 .N OCXPGM S OCXPGM=$O(^OCXS(860.3,"APGM",OCXD0,"")) Q:'$L(OCXPGM)  X "I $L($T("_OCXPGM_"))" E  Q
     135 .D @OCXPGM
     136 .S ^TMP("OCXCHK",$J,DFN,OCXD0)=$G(^TMP("OCXCHK",$J,DFN,OCXD0))+10
     137 K ^TMP("OCXCHK",$J)
     138 Q
     139 ;
     140TERM(OCXTERM,OCXLIST) ; Local Term Lookup
     141 ;  Internal Call.
     142 ;
     143 Q:$G(OCXOERR)
     144 ;
     145 Q:'$L(OCXTERM) 0
     146 ;
     147 N FILE,IEN,LINE,LTERM,NTERM,TEXT S FILE=0 K OCXLIST
     148 F LINE=1:1:999 S TEXT=$T(TERM+LINE) Q:$P(TEXT,";",2)  I ($E(TEXT,2,3)=";;") D
     149 .S TEXT=$P(TEXT,";;",2)
     150 .S NTERM=$P(TEXT,U,1) Q:'$L(NTERM)  Q:'(OCXTERM=NTERM)
     151 .S FILE=$P(TEXT,U,2),IEN=$P(TEXT,U,3),LTERM=$P(TEXT,U,4)
     152 .S OCXLIST(IEN)=LTERM,OCXLIST("B",LTERM,IEN)=""
     153 ;
     154 Q FILE
     155 ;
     156 ;TERM DATA;
     157 ;1;
     158 ;
     159 Q
     160 ;
     161DT2INT(OCXDT) ;      This Local Extrinsic Function converts a date into an integer
     162 ; By taking the Years, Months, Days, Hours and Minutes converting
     163 ; Them into Seconds and then adding them all together into one big integer
     164 ;
     165 Q:'$L($G(OCXDT)) ""
     166 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
     167 ;
     168 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
     169 .N OCXHR,OCXMIN,OCXTIME
     170 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
     171 .S:(OCXDT["Midnight") OCXHR=00
     172 .S:(OCXDT["PM") OCXHR=OCXHR+12
     173 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
     174 ;
     175 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
     176 .N OCXMON
     177 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     178 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
     179 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
     180 ;
     181 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
     182 .N OCXMON
     183 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     184 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
     185 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
     186 ;
     187 I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
     188 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
     189 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
     190 ;
     191 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
     192 ;
     193 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
     194 ;
     195 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
     196 ;
     197 Q OCXVAL
     198 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m

    r613 r623  
    1 OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK1    ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from UPDATE+10^OCXOZ01.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK1 Variables
    19         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    20         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    21         ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT)
    22         ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
    23         ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT)
    24         ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
    25         ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT)
    26         ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
    27         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    28         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    29         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    30         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    31         ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC)
    32         ;
    33         ;      Local Extrinsic Functions
    34         ; FILE(DFN,16, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 OERR ORDER)
    35         ; LIST( ------------> IN LIST OPERATOR
    36         ; PATLOC( ----------> PATIENT LOCATION
    37         ;
    38         I $L(OCXDF(23)) D CHK2
    39         I $L(OCXDF(1)) D CHK12^OCXOZ03
    40         I $L(OCXDF(2)),(OCXDF(2)="OR") S OCXOERR=$$FILE(DFN,16,"") Q:OCXOERR
    41         I $L(OCXDF(6)) D CHK34^OCXOZ04
    42         I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C") D CHK47^OCXOZ05
    43         I $L(OCXDF(34)) D CHK113^OCXOZ06
    44         I $L(OCXDF(5)),(OCXDF(5)="S") D CHK151^OCXOZ07
    45         I $L(OCXDF(21)),(OCXDF(21)="S") D CHK157^OCXOZ07
    46         I $L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)) D CHK436^OCXOZ0E
    47         I $L(OCXDF(12)),$L(OCXDF(152)),$L(OCXDF(113)) D CHK463^OCXOZ0F
    48         Q
    49         ;
    50 CHK2    ; Look through the current environment for valid Event/Elements for this patient.
    51         ;  Called from CHK1+25.
    52         ;
    53         Q:$G(OCXOERR)
    54         ;
    55         ;    Local CHK2 Variables
    56         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    57         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    58         ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
    59         ;
    60         ;      Local Extrinsic Functions
    61         ; LIST( ------------> IN LIST OPERATOR
    62         ;
    63         I $$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK6
    64         I (OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK121^OCXOZ07
    65         Q
    66         ;
    67 CHK6    ; Look through the current environment for valid Event/Elements for this patient.
    68         ;  Called from CHK2+13.
    69         ;
    70         Q:$G(OCXOERR)
    71         ;
    72         ;    Local CHK6 Variables
    73         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    74         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    75         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    76         ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
    77         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    78         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    79         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    80         ;
    81         ;      Local Extrinsic Functions
    82         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    83         ; PATLOC( ----------> PATIENT LOCATION
    84         ;
    85         I ($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK11
    86         I (OCXDF(2)="RA"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK302^OCXOZ0C
    87         I (OCXDF(2)="GMRC"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK336^OCXOZ0C
    88         Q
    89         ;
    90 CHK11   ; Look through the current environment for valid Event/Elements for this patient.
    91         ;  Called from CHK6+18.
    92         ;
    93         Q:$G(OCXOERR)
    94         ;
    95         ;      Local Extrinsic Functions
    96         ; FILE(DFN,5, ------> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 FINAL LAB RESULT)
    97         ;
    98         S OCXOERR=$$FILE(DFN,5,"12,37,96,113,147,152") Q:OCXOERR
    99         Q
    100         ;
    101 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    102         ;
    103         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    104         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    105         ;
    106         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    107         ;
    108         S OCXDATA(DFN,OCXELE)=1
    109         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    110         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    111         ;
    112         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    113         ;
    114         Q 0
    115         ;
    116 LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
    117         ;
    118         S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
    119         Q (LIST[DATA)
    120         ;
    121 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    122         Q:'$G(OIEN) ""
    123         ;
    124         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    125         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    126         Q $P(X,U,1)
    127         ;
    128 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    129         ;
    130         N OCXP1,OCXP2
    131         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    132         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    133         I OCXP2 D
    134         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    135         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    136         .E  S OCXP2=$P(OCXP2,"^",1)
    137         .S:'$L(OCXP2) OCXP2="NO LOC"
    138         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    139         ;
    140         S OCXP2=$G(^DPT(+$G(DFN),.1))
    141         I $L(OCXP2) Q "I^"_OCXP2
    142         Q "O^OUTPT"
    143         ;
     1OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK1 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from UPDATE+10^OCXOZ01.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK1 Variables
     19 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     20 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     21 ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT)
     22 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
     23 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT)
     24 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
     25 ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT)
     26 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
     27 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     28 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     29 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     30 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     31 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC)
     32 ;
     33 ;      Local Extrinsic Functions
     34 ; FILE(DFN,16, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 OERR ORDER)
     35 ; LIST( ------------> IN LIST OPERATOR
     36 ; PATLOC( ----------> PATIENT LOCATION
     37 ;
     38 I $L(OCXDF(23)) D CHK2
     39 I $L(OCXDF(1)) D CHK12^OCXOZ03
     40 I $L(OCXDF(2)),(OCXDF(2)="OR") S OCXOERR=$$FILE(DFN,16,"") Q:OCXOERR
     41 I $L(OCXDF(6)) D CHK34^OCXOZ04
     42 I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C") D CHK47^OCXOZ05
     43 I $L(OCXDF(34)) D CHK113^OCXOZ06
     44 I $L(OCXDF(5)),(OCXDF(5)="S") D CHK151^OCXOZ07
     45 I $L(OCXDF(21)),(OCXDF(21)="S") D CHK157^OCXOZ07
     46 I $L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)) D CHK444^OCXOZ0E
     47 I $L(OCXDF(12)),$L(OCXDF(152)),$L(OCXDF(113)) D CHK471^OCXOZ0F
     48 Q
     49 ;
     50CHK2 ; Look through the current environment for valid Event/Elements for this patient.
     51 ;  Called from CHK1+25.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;    Local CHK2 Variables
     56 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     57 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     58 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
     59 ;
     60 ;      Local Extrinsic Functions
     61 ; LIST( ------------> IN LIST OPERATOR
     62 ;
     63 I $$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK6
     64 I (OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK121^OCXOZ07
     65 Q
     66 ;
     67CHK6 ; Look through the current environment for valid Event/Elements for this patient.
     68 ;  Called from CHK2+13.
     69 ;
     70 Q:$G(OCXOERR)
     71 ;
     72 ;    Local CHK6 Variables
     73 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     74 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     75 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     76 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
     77 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     78 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     79 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     80 ;
     81 ;      Local Extrinsic Functions
     82 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     83 ; PATLOC( ----------> PATIENT LOCATION
     84 ;
     85 I ($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK11
     86 I (OCXDF(2)="RA"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK302^OCXOZ0C
     87 I (OCXDF(2)="GMRC"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK336^OCXOZ0C
     88 Q
     89 ;
     90CHK11 ; Look through the current environment for valid Event/Elements for this patient.
     91 ;  Called from CHK6+18.
     92 ;
     93 Q:$G(OCXOERR)
     94 ;
     95 ;      Local Extrinsic Functions
     96 ; FILE(DFN,5, ------> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 FINAL LAB RESULT)
     97 ;
     98 S OCXOERR=$$FILE(DFN,5,"12,37,96,113,147,152") Q:OCXOERR
     99 Q
     100 ;
     101FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     102 ;
     103 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     104 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     105 ;
     106 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     107 ;
     108 S OCXDATA(DFN,OCXELE)=1
     109 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     110 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     111 ;
     112 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     113 ;
     114 Q 0
     115 ;
     116LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
     117 ;
     118 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
     119 Q (LIST[DATA)
     120 ;
     121ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     122 Q:'$G(OIEN) ""
     123 ;
     124 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     125 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     126 Q $P(X,U,1)
     127 ;
     128PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     129 ;
     130 N OCXP1,OCXP2
     131 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     132 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     133 I OCXP2 D
     134 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     135 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     136 .E  S OCXP2=$P(OCXP2,"^",1)
     137 .S:'$L(OCXP2) OCXP2="NO LOC"
     138 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     139 ;
     140 S OCXP2=$G(^DPT(+$G(DFN),.1))
     141 I $L(OCXP2) Q "I^"_OCXP2
     142 Q "O^OUTPT"
     143 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m

    r613 r623  
    1 OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK12   ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK1+26^OCXOZ02.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK12 Variables
    19         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    20         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    21         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    22         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    23         ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT)
    24         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    25         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    26         ; OCXDF(148) --> Data Field: FOOD-DRUG INTERACTION MED (BOOLEAN)
    27         ;
    28         ;      Local Extrinsic Functions
    29         ; FILE(DFN,126, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 DCED OERR ORDER)
    30         ; FILE(DFN,20, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB ORDER CANCELLED)
    31         ; FILE(DFN,30, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER PUT ON-HOLD)
    32         ; FILE(DFN,31, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER CANCELLED)
    33         ; FILE(DFN,32, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER DISCONTINUED)
    34         ; FILE(DFN,40, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB REQUEST CANCELLED)
    35         ; FILE(DFN,6, ------> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 NEW OERR ORDER)
    36         ; FOODDRG( ---------> FOOD-DRUG INTERACTION MED
    37         ; LIST( ------------> IN LIST OPERATOR
    38         ; PATLOC( ----------> PATIENT LOCATION
    39         ;
    40         I $$LIST(OCXDF(1),"NW,SN,XR"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,6,"147") Q:OCXOERR
    41         I (OCXDF(1)="OC"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,20,"105") Q:OCXOERR
    42         I (OCXDF(1)="OH"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,30,"105") Q:OCXOERR
    43         I (OCXDF(1)="OD"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,31,"105") Q:OCXOERR
    44         I (OCXDF(1)="DC"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,32,"105") Q:OCXOERR
    45         I (OCXDF(1)="CA"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,40,"105") Q:OCXOERR
    46         I $$LIST(OCXDF(1),"NW,SN,XO"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK131^OCXOZ07
    47         I $$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(148)=$P($$FOODDRG(OCXDF(34)),"^",1) I $L(OCXDF(148)),(OCXDF(148)),$L(OCXDF(37)) D CHK270^OCXOZ0B
    48         I $$LIST(OCXDF(1),"DC,CA,OD,OC"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,126,"147") Q:OCXOERR
    49         Q
    50         ;
    51 CHK23   ; Look through the current environment for valid Event/Elements for this patient.
    52         ;  Called from UPDATE+11^OCXOZ01.
    53         ;
    54         Q:$G(OCXOERR)
    55         ;
    56         ;    Local CHK23 Variables
    57         ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT)
    58         ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC)
    59         ; OCXDF(93) ---> Data Field: PATIENT MOVEMENT WARD IEN PREVIOUS (NUMERIC)
    60         ; OCXDF(94) ---> Data Field: PATIENT MOVEMENT SERVICE PREVIOUS (FREE TEXT)
    61         ;
    62         ;      Local Extrinsic Functions
    63         ; POINTER( ---------> RETURN POINTED TO VALUE
    64         ; WARDSERV( --------> GET WARD SERVICE
    65         ;
    66         S OCXDF(25)=$$POINTER(405.3,$P($G(DGPMA),"^",2)) I $L(OCXDF(25)) D CHK25^OCXOZ04
    67         S OCXDF(93)=$P($G(DGPM0),"^",6) I $L(OCXDF(93)) S OCXDF(94)=$$WARDSERV(OCXDF(93)) I $L(OCXDF(94)),(OCXDF(94)="PSYCHIATRY") S OCXDF(92)=$P($G(DGPMA),"^",6) D CHK87^OCXOZ05
    68         Q
    69         ;
    70 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    71         ;
    72         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    73         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    74         ;
    75         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    76         ;
    77         S OCXDATA(DFN,OCXELE)=1
    78         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    79         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    80         ;
    81         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    82         ;
    83         Q 0
    84         ;
    85 FOODDRG(OCXOR)  ;func rtns 1^<med name> if OCXOR is food-drug med
    86         N OCXTL,OCXT,OCXFD,OCXOI
    87         S OCXOI=$$OI(OCXOR)
    88         Q:'$L(OCXOI) "0^"
    89         Q:'$$TERMLKUP("FOOD-DRUG INTERACTION MED",.OCXTL) "0^"
    90         S OCXFD="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D  Q:$L(OCXFD)
    91         .I OCXT=OCXOI S OCXFD="1^"_OCXTL(OCXT)
    92         Q:'$L(OCXFD) "0^"
    93         Q OCXFD
    94         ;
    95 LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
    96         ;
    97         S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
    98         Q (LIST[DATA)
    99         ;
    100 OI(OCXOR)       ;func rtns orderable item for an order number (OCXOR)
    101         Q:+$G(OCXOR)<1 ""
    102         N OCXOI S OCXOI=""
    103         S OCXOI=+$G(^OR(100,+$G(OCXOR),.1,1,0))
    104         Q OCXOI
    105         ;
    106 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    107         ;
    108         N OCXP1,OCXP2
    109         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    110         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    111         I OCXP2 D
    112         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    113         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    114         .E  S OCXP2=$P(OCXP2,"^",1)
    115         .S:'$L(OCXP2) OCXP2="NO LOC"
    116         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    117         ;
    118         S OCXP2=$G(^DPT(+$G(DFN),.1))
    119         I $L(OCXP2) Q "I^"_OCXP2
    120         Q "O^OUTPT"
    121         ;
    122 POINTER(OCXFILE,D0)     ;    This Local Extrinsic Function gets the value of the name field
    123         ;  of record D0 in file OCXFILE
    124         Q:'$G(D0) "" Q:'$L($G(OCXFILE)) ""
    125         N GLREF
    126         I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE
    127         E  S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) ""
    128         Q $P($G(@(GLREF_(+D0)_",0)")),U,1)
    129         ;
    130 TERMLKUP(OCXTERM,OCXLIST)       ;
    131         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    132         ;
    133 WARDSERV(WARD)  ;  Compiler Function: GET WARD SERVICE
    134         ;
    135         N CODESET,PC,SERV,DIC,X,Y,DA
    136         S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT"
    137         S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) ""
    138         S SERV=$P($G(Y(0)),U,3)
    139         Q:'$L(SERV) "" Q:'$L(CODESET) ""
    140         F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q
    141         Q:'PC "" Q $P($P(CODESET,";",PC),":",2)
    142         ;
     1OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK12 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK1+26^OCXOZ02.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK12 Variables
     19 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     20 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     21 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     22 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     23 ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT)
     24 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     25 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     26 ; OCXDF(148) --> Data Field: FOOD-DRUG INTERACTION MED (BOOLEAN)
     27 ;
     28 ;      Local Extrinsic Functions
     29 ; FILE(DFN,126, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 DCED OERR ORDER)
     30 ; FILE(DFN,20, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB ORDER CANCELLED)
     31 ; FILE(DFN,30, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER PUT ON-HOLD)
     32 ; FILE(DFN,31, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER CANCELLED)
     33 ; FILE(DFN,32, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER DISCONTINUED)
     34 ; FILE(DFN,40, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB REQUEST CANCELLED)
     35 ; FILE(DFN,6, ------> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 NEW OERR ORDER)
     36 ; FOODDRG( ---------> FOOD-DRUG INTERACTION MED
     37 ; LIST( ------------> IN LIST OPERATOR
     38 ; PATLOC( ----------> PATIENT LOCATION
     39 ;
     40 I $$LIST(OCXDF(1),"NW,SN,XR"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,6,"147") Q:OCXOERR
     41 I (OCXDF(1)="OC"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,20,"105") Q:OCXOERR
     42 I (OCXDF(1)="OH"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,30,"105") Q:OCXOERR
     43 I (OCXDF(1)="OD"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,31,"105") Q:OCXOERR
     44 I (OCXDF(1)="DC"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,32,"105") Q:OCXOERR
     45 I (OCXDF(1)="CA"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,40,"105") Q:OCXOERR
     46 I $$LIST(OCXDF(1),"NW,SN,XO"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK131^OCXOZ07
     47 I $$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(148)=$P($$FOODDRG(OCXDF(34)),"^",1) I $L(OCXDF(148)),(OCXDF(148)),$L(OCXDF(37)) D CHK270^OCXOZ0B
     48 I $$LIST(OCXDF(1),"DC,CA,OD,OC"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,126,"147") Q:OCXOERR
     49 Q
     50 ;
     51CHK23 ; Look through the current environment for valid Event/Elements for this patient.
     52 ;  Called from UPDATE+11^OCXOZ01.
     53 ;
     54 Q:$G(OCXOERR)
     55 ;
     56 ;    Local CHK23 Variables
     57 ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT)
     58 ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC)
     59 ; OCXDF(93) ---> Data Field: PATIENT MOVEMENT WARD IEN PREVIOUS (NUMERIC)
     60 ; OCXDF(94) ---> Data Field: PATIENT MOVEMENT SERVICE PREVIOUS (FREE TEXT)
     61 ;
     62 ;      Local Extrinsic Functions
     63 ; POINTER( ---------> RETURN POINTED TO VALUE
     64 ; WARDSERV( --------> GET WARD SERVICE
     65 ;
     66 S OCXDF(25)=$$POINTER(405.3,$P($G(DGPMA),"^",2)) I $L(OCXDF(25)) D CHK25^OCXOZ04
     67 S OCXDF(93)=$P($G(DGPM0),"^",6) I $L(OCXDF(93)) S OCXDF(94)=$$WARDSERV(OCXDF(93)) I $L(OCXDF(94)),(OCXDF(94)="PSYCHIATRY") S OCXDF(92)=$P($G(DGPMA),"^",6) D CHK87^OCXOZ05
     68 Q
     69 ;
     70FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     71 ;
     72 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     73 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     74 ;
     75 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     76 ;
     77 S OCXDATA(DFN,OCXELE)=1
     78 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     79 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     80 ;
     81 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     82 ;
     83 Q 0
     84 ;
     85FOODDRG(OCXOR) ;func rtns 1^<med name> if OCXOR is food-drug med
     86 N OCXTL,OCXT,OCXFD,OCXOI
     87 S OCXOI=$$OI(OCXOR)
     88 Q:'$L(OCXOI) "0^"
     89 Q:'$$TERMLKUP("FOOD-DRUG INTERACTION MED",.OCXTL) "0^"
     90 S OCXFD="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D  Q:$L(OCXFD)
     91 .I OCXT=OCXOI S OCXFD="1^"_OCXTL(OCXT)
     92 Q:'$L(OCXFD) "0^"
     93 Q OCXFD
     94 ;
     95LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
     96 ;
     97 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
     98 Q (LIST[DATA)
     99 ;
     100OI(OCXOR) ;func rtns orderable item for an order number (OCXOR)
     101 Q:+$G(OCXOR)<1 ""
     102 N OCXOI S OCXOI=""
     103 S OCXOI=+$G(^OR(100,+$G(OCXOR),.1,1,0))
     104 Q OCXOI
     105 ;
     106PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     107 ;
     108 N OCXP1,OCXP2
     109 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     110 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     111 I OCXP2 D
     112 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     113 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     114 .E  S OCXP2=$P(OCXP2,"^",1)
     115 .S:'$L(OCXP2) OCXP2="NO LOC"
     116 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     117 ;
     118 S OCXP2=$G(^DPT(+$G(DFN),.1))
     119 I $L(OCXP2) Q "I^"_OCXP2
     120 Q "O^OUTPT"
     121 ;
     122POINTER(OCXFILE,D0) ;    This Local Extrinsic Function gets the value of the name field
     123 ;  of record D0 in file OCXFILE
     124 Q:'$G(D0) "" Q:'$L($G(OCXFILE)) ""
     125 N GLREF
     126 I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE
     127 E  S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) ""
     128 Q $P($G(@(GLREF_(+D0)_",0)")),U,1)
     129 ;
     130TERMLKUP(OCXTERM,OCXLIST) ;
     131 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     132 ;
     133WARDSERV(WARD) ;  Compiler Function: GET WARD SERVICE
     134 ;
     135 N CODESET,PC,SERV,DIC,X,Y,DA
     136 S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT"
     137 S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) ""
     138 S SERV=$P($G(Y(0)),U,3)
     139 Q:'$L(SERV) "" Q:'$L(CODESET) ""
     140 F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q
     141 Q:'PC "" Q $P($P(CODESET,";",PC),":",2)
     142 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m

    r613 r623  
    1 OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK25   ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK23+15^OCXOZ03.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK25 Variables
    19         ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT)
    20         ; OCXDF(26) ---> Data Field: PATIENT MOVEMENT DATE CURRENT (DATE/TIME)
    21         ; OCXDF(97) ---> Data Field: NEW PATIENT MOVEMENT (BOOLEAN)
    22         ;
    23         ;      Local Extrinsic Functions
    24         ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT
    25         ; FILE(DFN,56, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT DISCHARGE)
    26         ;
    27         I (OCXDF(25)="ADMISSION") S OCXDF(97)=('(+$G(DGPMA)=+$G(DGPM0))&'$L(DGPMP)) I $L(OCXDF(97)),(OCXDF(97)) S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)) D CHK30
    28         I (OCXDF(25)="DISCHARGE") S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)),OCXOERR=$$FILE(DFN,56,"26") Q:OCXOERR
    29         Q
    30         ;
    31 CHK30   ; Look through the current environment for valid Event/Elements for this patient.
    32         ;  Called from CHK25+14.
    33         ;
    34         Q:$G(OCXOERR)
    35         ;
    36         ;    Local CHK30 Variables
    37         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    38         ; OCXDF(83) ---> Data Field: PATIENT WARD ROOM-BED (FREE TEXT)
    39         ;
    40         ;      Local Extrinsic Functions
    41         ; FILE(DFN,21, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT ADMISSION)
    42         ; WARDRMBD( --------> WARD ROOM-BED
    43         ;
    44         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(83)=$P($$WARDRMBD(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,21,"26,83") Q:OCXOERR
    45         Q
    46         ;
    47 CHK34   ; Look through the current environment for valid Event/Elements for this patient.
    48         ;  Called from CHK1+28^OCXOZ02.
    49         ;
    50         Q:$G(OCXOERR)
    51         ;
    52         ;    Local CHK34 Variables
    53         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    54         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    55         ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
    56         ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
    57         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    58         ;
    59         ;      Local Extrinsic Functions
    60         ; LIST( ------------> IN LIST OPERATOR
    61         ;
    62         I $$LIST(OCXDF(6),"H,L") D CHK35
    63         I $$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) D CHK324^OCXOZ0C
    64         Q
    65         ;
    66 CHK35   ; Look through the current environment for valid Event/Elements for this patient.
    67         ;  Called from CHK34+15.
    68         ;
    69         Q:$G(OCXOERR)
    70         ;
    71         ;    Local CHK35 Variables
    72         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    73         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    74         ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
    75         ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
    76         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    77         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    78         ;
    79         ;      Local Extrinsic Functions
    80         ; LIST( ------------> IN LIST OPERATOR
    81         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    82         ;
    83         I $L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK43
    84         I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK314^OCXOZ0C
    85         Q
    86         ;
    87 CHK43   ; Look through the current environment for valid Event/Elements for this patient.
    88         ;  Called from CHK35+17.
    89         ;
    90         Q:$G(OCXOERR)
    91         ;
    92         ;    Local CHK43 Variables
    93         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    94         ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
    95         ;
    96         ;      Local Extrinsic Functions
    97         ; FILE(DFN,23, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB ORDER RESULTS ABNORMAL)
    98         ;
    99         I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,23,"12,13,96,114") Q:OCXOERR
    100         Q
    101         ;
    102 DT2INT(OCXDT)   ;      This Local Extrinsic Function converts a date into an integer
    103         ; By taking the Years, Months, Days, Hours and Minutes converting
    104         ; Them into Seconds and then adding them all together into one big integer
    105         ;
    106         Q:'$L($G(OCXDT)) ""
    107         N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
    108         ;
    109         I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
    110         .N OCXHR,OCXMIN,OCXTIME
    111         .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
    112         .S:(OCXDT["Midnight") OCXHR=00
    113         .S:(OCXDT["PM") OCXHR=OCXHR+12
    114         .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
    115         ;
    116         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
    117         .N OCXMON
    118         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    119         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
    120         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
    121         ;
    122         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
    123         .N OCXMON
    124         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    125         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
    126         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
    127         ;
    128         I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
    129         .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
    130         .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
    131         ;
    132         I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
    133         ;
    134         I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
    135         ;
    136         I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
    137         ;
    138         Q OCXVAL
    139         ;
    140 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    141         ;
    142         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    143         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    144         ;
    145         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    146         ;
    147         S OCXDATA(DFN,OCXELE)=1
    148         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    149         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    150         ;
    151         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    152         ;
    153         Q 0
    154         ;
    155 LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
    156         ;
    157         S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
    158         Q (LIST[DATA)
    159         ;
    160 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    161         Q:'$G(OIEN) ""
    162         ;
    163         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    164         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    165         Q $P(X,U,1)
    166         ;
    167 WARDRMBD(DFN)   ;  Compiler Function: WARD ROOM-BED
    168         ;
    169         Q:'$G(DFN) 0
    170         N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0
    171         S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT
    172         ;
     1OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK25 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK23+15^OCXOZ03.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK25 Variables
     19 ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT)
     20 ; OCXDF(26) ---> Data Field: PATIENT MOVEMENT DATE CURRENT (DATE/TIME)
     21 ; OCXDF(97) ---> Data Field: NEW PATIENT MOVEMENT (BOOLEAN)
     22 ;
     23 ;      Local Extrinsic Functions
     24 ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT
     25 ; FILE(DFN,56, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT DISCHARGE)
     26 ;
     27 I (OCXDF(25)="ADMISSION") S OCXDF(97)=('(+$G(DGPMA)=+$G(DGPM0))&'$L(DGPMP)) I $L(OCXDF(97)),(OCXDF(97)) S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)) D CHK30
     28 I (OCXDF(25)="DISCHARGE") S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)),OCXOERR=$$FILE(DFN,56,"26") Q:OCXOERR
     29 Q
     30 ;
     31CHK30 ; Look through the current environment for valid Event/Elements for this patient.
     32 ;  Called from CHK25+14.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 ;    Local CHK30 Variables
     37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     38 ; OCXDF(83) ---> Data Field: PATIENT WARD ROOM-BED (FREE TEXT)
     39 ;
     40 ;      Local Extrinsic Functions
     41 ; FILE(DFN,21, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT ADMISSION)
     42 ; WARDRMBD( --------> WARD ROOM-BED
     43 ;
     44 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(83)=$P($$WARDRMBD(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,21,"26,83") Q:OCXOERR
     45 Q
     46 ;
     47CHK34 ; Look through the current environment for valid Event/Elements for this patient.
     48 ;  Called from CHK1+28^OCXOZ02.
     49 ;
     50 Q:$G(OCXOERR)
     51 ;
     52 ;    Local CHK34 Variables
     53 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     54 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     55 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
     56 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
     57 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     58 ;
     59 ;      Local Extrinsic Functions
     60 ; LIST( ------------> IN LIST OPERATOR
     61 ;
     62 I $$LIST(OCXDF(6),"H,L") D CHK35
     63 I $$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) D CHK324^OCXOZ0C
     64 Q
     65 ;
     66CHK35 ; Look through the current environment for valid Event/Elements for this patient.
     67 ;  Called from CHK34+15.
     68 ;
     69 Q:$G(OCXOERR)
     70 ;
     71 ;    Local CHK35 Variables
     72 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     73 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     74 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
     75 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
     76 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     77 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     78 ;
     79 ;      Local Extrinsic Functions
     80 ; LIST( ------------> IN LIST OPERATOR
     81 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     82 ;
     83 I $L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK43
     84 I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK314^OCXOZ0C
     85 Q
     86 ;
     87CHK43 ; Look through the current environment for valid Event/Elements for this patient.
     88 ;  Called from CHK35+17.
     89 ;
     90 Q:$G(OCXOERR)
     91 ;
     92 ;    Local CHK43 Variables
     93 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     94 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
     95 ;
     96 ;      Local Extrinsic Functions
     97 ; FILE(DFN,23, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB ORDER RESULTS ABNORMAL)
     98 ;
     99 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,23,"12,13,96,114") Q:OCXOERR
     100 Q
     101 ;
     102DT2INT(OCXDT) ;      This Local Extrinsic Function converts a date into an integer
     103 ; By taking the Years, Months, Days, Hours and Minutes converting
     104 ; Them into Seconds and then adding them all together into one big integer
     105 ;
     106 Q:'$L($G(OCXDT)) ""
     107 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
     108 ;
     109 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
     110 .N OCXHR,OCXMIN,OCXTIME
     111 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
     112 .S:(OCXDT["Midnight") OCXHR=00
     113 .S:(OCXDT["PM") OCXHR=OCXHR+12
     114 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
     115 ;
     116 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
     117 .N OCXMON
     118 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     119 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
     120 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
     121 ;
     122 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
     123 .N OCXMON
     124 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     125 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
     126 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
     127 ;
     128 I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
     129 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
     130 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
     131 ;
     132 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
     133 ;
     134 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
     135 ;
     136 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
     137 ;
     138 Q OCXVAL
     139 ;
     140FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     141 ;
     142 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     143 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     144 ;
     145 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     146 ;
     147 S OCXDATA(DFN,OCXELE)=1
     148 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     149 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     150 ;
     151 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     152 ;
     153 Q 0
     154 ;
     155LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
     156 ;
     157 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
     158 Q (LIST[DATA)
     159 ;
     160ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     161 Q:'$G(OIEN) ""
     162 ;
     163 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     164 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     165 Q $P(X,U,1)
     166 ;
     167WARDRMBD(DFN) ;  Compiler Function: WARD ROOM-BED
     168 ;
     169 Q:'$G(DFN) 0
     170 N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0
     171 S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT
     172 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m

    r613 r623  
    1 OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK47   ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK1+29^OCXOZ02.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK47 Variables
    19         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    20         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    21         ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
    22         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    23         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    24         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    25         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    26         ;
    27         ;      Local Extrinsic Functions
    28         ; LIST( ------------> IN LIST OPERATOR
    29         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    30         ; PATLOC( ----------> PATIENT LOCATION
    31         ;
    32         I $L(OCXDF(6)),$$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK55
    33         I $L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK144^OCXOZ07
    34         Q
    35         ;
    36 CHK55   ; Look through the current environment for valid Event/Elements for this patient.
    37         ;  Called from CHK47+19.
    38         ;
    39         Q:$G(OCXOERR)
    40         ;
    41         ;    Local CHK55 Variables
    42         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    43         ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
    44         ;
    45         ;      Local Extrinsic Functions
    46         ; FILE(DFN,24, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB TEST RESULTS CRITICAL)
    47         ;
    48         I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,24,"12,13,96,114") Q:OCXOERR
    49         Q
    50         ;
    51 CHK58   ; Look through the current environment for valid Event/Elements for this patient.
    52         ;  Called from UPDATE+12^OCXOZ01.
    53         ;
    54         Q:$G(OCXOERR)
    55         ;
    56         ;    Local CHK58 Variables
    57         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    58         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    59         ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT)
    60         ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT)
    61         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    62         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    63         ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT)
    64         ;
    65         ;      Local Extrinsic Functions
    66         ; DMED64( ----------> DANGEROUS MEDS FOR PATIENTS > 64
    67         ;
    68         S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK60
    69         S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)) D CHK163^OCXOZ07
    70         S OCXDF(47)=$P($P($G(OCXPSD),"|",3),"^",5) I $L(OCXDF(47)) D CHK188^OCXOZ09
    71         S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK347^OCXOZ0C
    72         S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(143)=$P($$DMED64(OCXDF(73)),"^",2) I $L(OCXDF(143)) D CHK398^OCXOZ0D
    73         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK446^OCXOZ0F
    74         Q
    75         ;
    76 CHK60   ; Look through the current environment for valid Event/Elements for this patient.
    77         ;  Called from CHK58+17.
    78         ;
    79         Q:$G(OCXOERR)
    80         ;
    81         ;    Local CHK60 Variables
    82         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    83         ;
    84         ;      Local Extrinsic Functions
    85         ; FILE(DFN,135, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: DIET ORDER)
    86         ; FILE(DFN,137, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PHARMACY ORDER)
    87         ; FILE(DFN,28, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER)
    88         ;
    89         I (OCXDF(2)="RA") S OCXOERR=$$FILE(DFN,28,"") Q:OCXOERR
    90         I (OCXDF(2)="FH") S OCXOERR=$$FILE(DFN,135,"") Q:OCXOERR
    91         I ($E(OCXDF(2),1,2)="PS") S OCXOERR=$$FILE(DFN,137,"") Q:OCXOERR
    92         Q
    93         ;
    94 CHK87   ; Look through the current environment for valid Event/Elements for this patient.
    95         ;  Called from CHK23+16^OCXOZ03.
    96         ;
    97         Q:$G(OCXOERR)
    98         ;
    99         ;    Local CHK87 Variables
    100         ; OCXDF(90) ---> Data Field: PATIENT MOVEMENT WARD CURRENT (FREE TEXT)
    101         ; OCXDF(91) ---> Data Field: PATIENT MOVEMENT SERVICE CURRENT (FREE TEXT)
    102         ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC)
    103         ;
    104         ;      Local Extrinsic Functions
    105         ; POINTER( ---------> RETURN POINTED TO VALUE
    106         ; WARDSERV( --------> GET WARD SERVICE
    107         ;
    108         I $L(OCXDF(92)) S OCXDF(91)=$$WARDSERV(OCXDF(92)) I $L(OCXDF(91)),($L(OCXDF(91))>0),'(OCXDF(91)="PSYCHIATRY") S OCXDF(90)=$$POINTER(42,$P($G(DGPMA),"^",6)) D CHK93
    109         Q
    110         ;
    111 CHK93   ; Look through the current environment for valid Event/Elements for this patient.
    112         ;  Called from CHK87+14.
    113         ;
    114         Q:$G(OCXOERR)
    115         ;
    116         ;    Local CHK93 Variables
    117         ; OCXDF(95) ---> Data Field: PATIENT MOVEMENT WARD PREVIOUS (FREE TEXT)
    118         ;
    119         ;      Local Extrinsic Functions
    120         ; FILE(DFN,42, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD)
    121         ; POINTER( ---------> RETURN POINTED TO VALUE
    122         ;
    123         S OCXDF(95)=$$POINTER(42,$P($G(DGPM0),"^",6)),OCXOERR=$$FILE(DFN,42,"90,95") Q:OCXOERR
    124         Q
    125         ;
    126 DMED64(OCXOI)     ;ext func rtns med oi^med name if OCXOI is dangerous
    127         N OCXTL,OCXT,OCXDM
    128         Q:'$$TERMLKUP("DANGEROUS MEDS FOR PTS > 64",.OCXTL) "0^"
    129         S OCXDM="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D  Q:$L(OCXDM)
    130         .I OCXT=OCXOI S OCXDM=OCXT_"^"_OCXTL(OCXT)
    131         Q:'$L(OCXDM) "0^"
    132         Q OCXDM
    133         ;
    134 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    135         ;
    136         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    137         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    138         ;
    139         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    140         ;
    141         S OCXDATA(DFN,OCXELE)=1
    142         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    143         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    144         ;
    145         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    146         ;
    147         Q 0
    148         ;
    149 LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
    150         ;
    151         S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
    152         Q (LIST[DATA)
    153         ;
    154 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    155         Q:'$G(OIEN) ""
    156         ;
    157         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    158         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    159         Q $P(X,U,1)
    160         ;
    161 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    162         ;
    163         N OCXP1,OCXP2
    164         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    165         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    166         I OCXP2 D
    167         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    168         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    169         .E  S OCXP2=$P(OCXP2,"^",1)
    170         .S:'$L(OCXP2) OCXP2="NO LOC"
    171         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    172         ;
    173         S OCXP2=$G(^DPT(+$G(DFN),.1))
    174         I $L(OCXP2) Q "I^"_OCXP2
    175         Q "O^OUTPT"
    176         ;
    177 POINTER(OCXFILE,D0)     ;    This Local Extrinsic Function gets the value of the name field
    178         ;  of record D0 in file OCXFILE
    179         Q:'$G(D0) "" Q:'$L($G(OCXFILE)) ""
    180         N GLREF
    181         I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE
    182         E  S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) ""
    183         Q $P($G(@(GLREF_(+D0)_",0)")),U,1)
    184         ;
    185 TERMLKUP(OCXTERM,OCXLIST)       ;
    186         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    187         ;
    188 WARDSERV(WARD)  ;  Compiler Function: GET WARD SERVICE
    189         ;
    190         N CODESET,PC,SERV,DIC,X,Y,DA
    191         S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT"
    192         S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) ""
    193         S SERV=$P($G(Y(0)),U,3)
    194         Q:'$L(SERV) "" Q:'$L(CODESET) ""
    195         F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q
    196         Q:'PC "" Q $P($P(CODESET,";",PC),":",2)
    197         ;
     1OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK47 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK1+29^OCXOZ02.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK47 Variables
     19 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     20 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     21 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT)
     22 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     23 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     24 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     25 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     26 ;
     27 ;      Local Extrinsic Functions
     28 ; LIST( ------------> IN LIST OPERATOR
     29 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     30 ; PATLOC( ----------> PATIENT LOCATION
     31 ;
     32 I $L(OCXDF(6)),$$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK55
     33 I $L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK144^OCXOZ07
     34 Q
     35 ;
     36CHK55 ; Look through the current environment for valid Event/Elements for this patient.
     37 ;  Called from CHK47+19.
     38 ;
     39 Q:$G(OCXOERR)
     40 ;
     41 ;    Local CHK55 Variables
     42 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     43 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
     44 ;
     45 ;      Local Extrinsic Functions
     46 ; FILE(DFN,24, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB TEST RESULTS CRITICAL)
     47 ;
     48 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,24,"12,13,96,114") Q:OCXOERR
     49 Q
     50 ;
     51CHK58 ; Look through the current environment for valid Event/Elements for this patient.
     52 ;  Called from UPDATE+12^OCXOZ01.
     53 ;
     54 Q:$G(OCXOERR)
     55 ;
     56 ;    Local CHK58 Variables
     57 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     58 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     59 ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT)
     60 ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT)
     61 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     62 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     63 ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT)
     64 ;
     65 ;      Local Extrinsic Functions
     66 ; DMED64( ----------> DANGEROUS MEDS FOR PATIENTS > 64
     67 ;
     68 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK60
     69 S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)) D CHK163^OCXOZ07
     70 S OCXDF(47)=$P($P($G(OCXPSD),"|",3),"^",5) I $L(OCXDF(47)) D CHK188^OCXOZ09
     71 S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK347^OCXOZ0C
     72 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(143)=$P($$DMED64(OCXDF(73)),"^",2) I $L(OCXDF(143)) D CHK406^OCXOZ0E
     73 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK454^OCXOZ0F
     74 Q
     75 ;
     76CHK60 ; Look through the current environment for valid Event/Elements for this patient.
     77 ;  Called from CHK58+17.
     78 ;
     79 Q:$G(OCXOERR)
     80 ;
     81 ;    Local CHK60 Variables
     82 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     83 ;
     84 ;      Local Extrinsic Functions
     85 ; FILE(DFN,135, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: DIET ORDER)
     86 ; FILE(DFN,137, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PHARMACY ORDER)
     87 ; FILE(DFN,28, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY ORDER)
     88 ;
     89 I (OCXDF(2)="RA") S OCXOERR=$$FILE(DFN,28,"") Q:OCXOERR
     90 I (OCXDF(2)="FH") S OCXOERR=$$FILE(DFN,135,"") Q:OCXOERR
     91 I ($E(OCXDF(2),1,2)="PS") S OCXOERR=$$FILE(DFN,137,"") Q:OCXOERR
     92 Q
     93 ;
     94CHK87 ; Look through the current environment for valid Event/Elements for this patient.
     95 ;  Called from CHK23+16^OCXOZ03.
     96 ;
     97 Q:$G(OCXOERR)
     98 ;
     99 ;    Local CHK87 Variables
     100 ; OCXDF(90) ---> Data Field: PATIENT MOVEMENT WARD CURRENT (FREE TEXT)
     101 ; OCXDF(91) ---> Data Field: PATIENT MOVEMENT SERVICE CURRENT (FREE TEXT)
     102 ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC)
     103 ;
     104 ;      Local Extrinsic Functions
     105 ; POINTER( ---------> RETURN POINTED TO VALUE
     106 ; WARDSERV( --------> GET WARD SERVICE
     107 ;
     108 I $L(OCXDF(92)) S OCXDF(91)=$$WARDSERV(OCXDF(92)) I $L(OCXDF(91)),($L(OCXDF(91))>0),'(OCXDF(91)="PSYCHIATRY") S OCXDF(90)=$$POINTER(42,$P($G(DGPMA),"^",6)) D CHK93
     109 Q
     110 ;
     111CHK93 ; Look through the current environment for valid Event/Elements for this patient.
     112 ;  Called from CHK87+14.
     113 ;
     114 Q:$G(OCXOERR)
     115 ;
     116 ;    Local CHK93 Variables
     117 ; OCXDF(95) ---> Data Field: PATIENT MOVEMENT WARD PREVIOUS (FREE TEXT)
     118 ;
     119 ;      Local Extrinsic Functions
     120 ; FILE(DFN,42, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD)
     121 ; POINTER( ---------> RETURN POINTED TO VALUE
     122 ;
     123 S OCXDF(95)=$$POINTER(42,$P($G(DGPM0),"^",6)),OCXOERR=$$FILE(DFN,42,"90,95") Q:OCXOERR
     124 Q
     125 ;
     126DMED64(OCXOI)   ;ext func rtns med oi^med name if OCXOI is dangerous
     127 N OCXTL,OCXT,OCXDM
     128 Q:'$$TERMLKUP("DANGEROUS MEDS FOR PTS > 64",.OCXTL) "0^"
     129 S OCXDM="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D  Q:$L(OCXDM)
     130 .I OCXT=OCXOI S OCXDM=OCXT_"^"_OCXTL(OCXT)
     131 Q:'$L(OCXDM) "0^"
     132 Q OCXDM
     133 ;
     134FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     135 ;
     136 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     137 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     138 ;
     139 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     140 ;
     141 S OCXDATA(DFN,OCXELE)=1
     142 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     143 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     144 ;
     145 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     146 ;
     147 Q 0
     148 ;
     149LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
     150 ;
     151 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
     152 Q (LIST[DATA)
     153 ;
     154ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     155 Q:'$G(OIEN) ""
     156 ;
     157 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     158 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     159 Q $P(X,U,1)
     160 ;
     161PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     162 ;
     163 N OCXP1,OCXP2
     164 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     165 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     166 I OCXP2 D
     167 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     168 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     169 .E  S OCXP2=$P(OCXP2,"^",1)
     170 .S:'$L(OCXP2) OCXP2="NO LOC"
     171 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     172 ;
     173 S OCXP2=$G(^DPT(+$G(DFN),.1))
     174 I $L(OCXP2) Q "I^"_OCXP2
     175 Q "O^OUTPT"
     176 ;
     177POINTER(OCXFILE,D0) ;    This Local Extrinsic Function gets the value of the name field
     178 ;  of record D0 in file OCXFILE
     179 Q:'$G(D0) "" Q:'$L($G(OCXFILE)) ""
     180 N GLREF
     181 I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE
     182 E  S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) ""
     183 Q $P($G(@(GLREF_(+D0)_",0)")),U,1)
     184 ;
     185TERMLKUP(OCXTERM,OCXLIST) ;
     186 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     187 ;
     188WARDSERV(WARD) ;  Compiler Function: GET WARD SERVICE
     189 ;
     190 N CODESET,PC,SERV,DIC,X,Y,DA
     191 S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT"
     192 S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) ""
     193 S SERV=$P($G(Y(0)),U,3)
     194 Q:'$L(SERV) "" Q:'$L(CODESET) ""
     195 F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q
     196 Q:'PC "" Q $P($P(CODESET,";",PC),":",2)
     197 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m

    r613 r623  
    1 OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK95   ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from UPDATE+13^OCXOZ01.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK95 Variables
    19         ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN)
    20         ; OCXDF(28) ---> Data Field: ORDER REQ. CHART SIGN. (BOOLEAN)
    21         ; OCXDF(29) ---> Data Field: SERV. ORDER REQ CHART SIG. (BOOLEAN)
    22         ; OCXDF(30) ---> Data Field: ORDER REQ. CO-SIG. (BOOLEAN)
    23         ; OCXDF(31) ---> Data Field: ORDER REQ. ELEC. SIG. (BOOLEAN)
    24         ;
    25         ;      Local Extrinsic Functions
    26         ; FILE(DFN,45, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER REQUIRES CHART SIGNATURE)
    27         ; FILE(DFN,46, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE)
    28         ; FILE(DFN,47, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER REQUIRES CO-SIGNATURE)
    29         ; FILE(DFN,48, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE)
    30         ;
    31         S OCXDF(27)=$P($G(OCXORD),"^",4) I $L(OCXDF(27)) D CHK97
    32         S OCXDF(28)=$P($G(OCXORD),"^",5) I $L(OCXDF(28)),(OCXDF(28)) S OCXOERR=$$FILE(DFN,45,"") Q:OCXOERR
    33         S OCXDF(29)=$P($G(OCXORD),"^",6) I $L(OCXDF(29)),(OCXDF(29)) S OCXOERR=$$FILE(DFN,46,"") Q:OCXOERR
    34         S OCXDF(30)=$P($G(OCXORD),"^",7) I $L(OCXDF(30)),(OCXDF(30)) S OCXOERR=$$FILE(DFN,47,"") Q:OCXOERR
    35         S OCXDF(31)=$P($G(OCXORD),"^",8) I $L(OCXDF(31)),(OCXDF(31)) S OCXOERR=$$FILE(DFN,48,"") Q:OCXOERR
    36         Q
    37         ;
    38 CHK97   ; Look through the current environment for valid Event/Elements for this patient.
    39         ;  Called from CHK95+18.
    40         ;
    41         Q:$G(OCXOERR)
    42         ;
    43         ;    Local CHK97 Variables
    44         ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN)
    45         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    46         ; OCXDF(115) --> Data Field: CURRENT DATE/TIME (FREE TEXT)
    47         ;
    48         ;      Local Extrinsic Functions
    49         ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT
    50         ; FILE(DFN,134, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER UNFLAGGED)
    51         ; FILE(DFN,44, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER FLAGGED)
    52         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    53         ;
    54         I (OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,44,"37,115") Q:OCXOERR
    55         I '(OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,134,"37,115") Q:OCXOERR
    56         Q
    57         ;
    58 CHK113  ; Look through the current environment for valid Event/Elements for this patient.
    59         ;  Called from CHK1+30^OCXOZ02.
    60         ;
    61         Q:$G(OCXOERR)
    62         ;
    63         ;    Local CHK113 Variables
    64         ; OCXDF(32) ---> Data Field: ORDER FLAGGED FOR RESULTS (BOOLEAN)
    65         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    66         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    67         ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT)
    68         ; OCXDF(112) --> Data Field: ORDERED BY (FREE TEXT)
    69         ; OCXDF(149) --> Data Field: ORDER CANCELED BY (FREE TEXT)
    70         ;
    71         ;      Local Extrinsic Functions
    72         ; CANCELER( --------> ORDER CANCELING PROVIDER
    73         ; FILE(DFN,49, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER FLAGGED FOR RESULTS)
    74         ; ORDERER( ---------> ORDERING PROVIDER
    75         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    76         ;
    77         S OCXDF(32)=$$RSLTFLG^ORQOR2(OCXDF(34)) I $L(OCXDF(32)),(OCXDF(32)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,49,"96") Q:OCXOERR
    78         S OCXDF(112)=$$ORDERER(OCXDF(34)),OCXDF(149)=$$CANCELER(OCXDF(34)) I '(OCXDF(112)=OCXDF(149)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2) D CHK293^OCXOZ0B
    79         Q
    80         ;
    81 CANCELER(ORNUM) ;  Compiler Function: ORDER CANCELING PROVIDER
    82         ;
    83         Q:'$G(ORNUM) ""
    84         S ORNUM=+$G(ORNUM)
    85         N ORQDUZ
    86         Q:'$D(^OR(100,ORNUM,6)) ""
    87         S ORQDUZ=$P(^OR(100,ORNUM,6),U,2)
    88         Q ORQDUZ
    89         ;
    90 DT2INT(OCXDT)   ;      This Local Extrinsic Function converts a date into an integer
    91         ; By taking the Years, Months, Days, Hours and Minutes converting
    92         ; Them into Seconds and then adding them all together into one big integer
    93         ;
    94         Q:'$L($G(OCXDT)) ""
    95         N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
    96         ;
    97         I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
    98         .N OCXHR,OCXMIN,OCXTIME
    99         .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
    100         .S:(OCXDT["Midnight") OCXHR=00
    101         .S:(OCXDT["PM") OCXHR=OCXHR+12
    102         .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
    103         ;
    104         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
    105         .N OCXMON
    106         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    107         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
    108         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
    109         ;
    110         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
    111         .N OCXMON
    112         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    113         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
    114         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
    115         ;
    116         I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
    117         .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
    118         .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
    119         ;
    120         I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
    121         ;
    122         I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
    123         ;
    124         I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
    125         ;
    126         Q OCXVAL
    127         ;
    128 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    129         ;
    130         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    131         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    132         ;
    133         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    134         ;
    135         S OCXDATA(DFN,OCXELE)=1
    136         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    137         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    138         ;
    139         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    140         ;
    141         Q 0
    142         ;
    143 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    144         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    145         ;
    146         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    147         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    148         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    149         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    150         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    151         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    152         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    153         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    154         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    155         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    156         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    157         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    158         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    159         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    160         E  S OCXMON=$E(OCXMON+100,2,3)
    161         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    162         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    163         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    164         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    165         Q OCXMON_" "_OCXDAY_","_OCXYR
    166         ;
    167 ORDERER(ORNUM)  ;  Compiler Function: ORDERING PROVIDER
    168         ;
    169         Q:'$G(ORNUM) ""
    170         S ORNUM=+$G(ORNUM)
    171         N ORQDUZ,ORQI S ORQDUZ=""
    172         I $L($G(^OR(100,ORNUM,8,0))) D
    173         .S ORQI=0,ORQI=$O(^OR(100,ORNUM,8,"C","NW",ORQI))
    174         Q:+$G(ORQI)<1 ""
    175         S ORQDUZ=$P(^OR(100,ORNUM,8,ORQI,0),U,3)
    176         Q ORQDUZ
    177         ;
    178 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    179         Q:'$G(OIEN) ""
    180         ;
    181         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    182         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    183         Q $P(X,U,1)
    184         ;
     1OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK95 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from UPDATE+13^OCXOZ01.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK95 Variables
     19 ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN)
     20 ; OCXDF(28) ---> Data Field: ORDER REQ. CHART SIGN. (BOOLEAN)
     21 ; OCXDF(29) ---> Data Field: SERV. ORDER REQ CHART SIG. (BOOLEAN)
     22 ; OCXDF(30) ---> Data Field: ORDER REQ. CO-SIG. (BOOLEAN)
     23 ; OCXDF(31) ---> Data Field: ORDER REQ. ELEC. SIG. (BOOLEAN)
     24 ;
     25 ;      Local Extrinsic Functions
     26 ; FILE(DFN,45, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER REQUIRES CHART SIGNATURE)
     27 ; FILE(DFN,46, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE)
     28 ; FILE(DFN,47, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER REQUIRES CO-SIGNATURE)
     29 ; FILE(DFN,48, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE)
     30 ;
     31 S OCXDF(27)=$P($G(OCXORD),"^",4) I $L(OCXDF(27)) D CHK97
     32 S OCXDF(28)=$P($G(OCXORD),"^",5) I $L(OCXDF(28)),(OCXDF(28)) S OCXOERR=$$FILE(DFN,45,"") Q:OCXOERR
     33 S OCXDF(29)=$P($G(OCXORD),"^",6) I $L(OCXDF(29)),(OCXDF(29)) S OCXOERR=$$FILE(DFN,46,"") Q:OCXOERR
     34 S OCXDF(30)=$P($G(OCXORD),"^",7) I $L(OCXDF(30)),(OCXDF(30)) S OCXOERR=$$FILE(DFN,47,"") Q:OCXOERR
     35 S OCXDF(31)=$P($G(OCXORD),"^",8) I $L(OCXDF(31)),(OCXDF(31)) S OCXOERR=$$FILE(DFN,48,"") Q:OCXOERR
     36 Q
     37 ;
     38CHK97 ; Look through the current environment for valid Event/Elements for this patient.
     39 ;  Called from CHK95+18.
     40 ;
     41 Q:$G(OCXOERR)
     42 ;
     43 ;    Local CHK97 Variables
     44 ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN)
     45 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     46 ; OCXDF(115) --> Data Field: CURRENT DATE/TIME (FREE TEXT)
     47 ;
     48 ;      Local Extrinsic Functions
     49 ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT
     50 ; FILE(DFN,134, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER UNFLAGGED)
     51 ; FILE(DFN,44, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER FLAGGED)
     52 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     53 ;
     54 I (OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,44,"37,115") Q:OCXOERR
     55 I '(OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,134,"37,115") Q:OCXOERR
     56 Q
     57 ;
     58CHK113 ; Look through the current environment for valid Event/Elements for this patient.
     59 ;  Called from CHK1+30^OCXOZ02.
     60 ;
     61 Q:$G(OCXOERR)
     62 ;
     63 ;    Local CHK113 Variables
     64 ; OCXDF(32) ---> Data Field: ORDER FLAGGED FOR RESULTS (BOOLEAN)
     65 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     66 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     67 ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT)
     68 ; OCXDF(112) --> Data Field: ORDERED BY (FREE TEXT)
     69 ; OCXDF(149) --> Data Field: ORDER CANCELED BY (FREE TEXT)
     70 ;
     71 ;      Local Extrinsic Functions
     72 ; CANCELER( --------> ORDER CANCELING PROVIDER
     73 ; FILE(DFN,49, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ORDER FLAGGED FOR RESULTS)
     74 ; ORDERER( ---------> ORDERING PROVIDER
     75 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     76 ;
     77 S OCXDF(32)=$$RSLTFLG^ORQOR2(OCXDF(34)) I $L(OCXDF(32)),(OCXDF(32)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,49,"96") Q:OCXOERR
     78 S OCXDF(112)=$$ORDERER(OCXDF(34)),OCXDF(149)=$$CANCELER(OCXDF(34)) I '(OCXDF(112)=OCXDF(149)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2) D CHK293^OCXOZ0B
     79 Q
     80 ;
     81CANCELER(ORNUM) ;  Compiler Function: ORDER CANCELING PROVIDER
     82 ;
     83 Q:'$G(ORNUM) ""
     84 S ORNUM=+$G(ORNUM)
     85 N ORQDUZ
     86 Q:'$D(^OR(100,ORNUM,6)) ""
     87 S ORQDUZ=$P(^OR(100,ORNUM,6),U,2)
     88 Q ORQDUZ
     89 ;
     90DT2INT(OCXDT) ;      This Local Extrinsic Function converts a date into an integer
     91 ; By taking the Years, Months, Days, Hours and Minutes converting
     92 ; Them into Seconds and then adding them all together into one big integer
     93 ;
     94 Q:'$L($G(OCXDT)) ""
     95 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
     96 ;
     97 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
     98 .N OCXHR,OCXMIN,OCXTIME
     99 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
     100 .S:(OCXDT["Midnight") OCXHR=00
     101 .S:(OCXDT["PM") OCXHR=OCXHR+12
     102 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
     103 ;
     104 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
     105 .N OCXMON
     106 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     107 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
     108 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
     109 ;
     110 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
     111 .N OCXMON
     112 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     113 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
     114 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
     115 ;
     116 I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
     117 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
     118 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
     119 ;
     120 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
     121 ;
     122 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
     123 ;
     124 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
     125 ;
     126 Q OCXVAL
     127 ;
     128FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     129 ;
     130 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     131 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     132 ;
     133 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     134 ;
     135 S OCXDATA(DFN,OCXELE)=1
     136 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     137 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     138 ;
     139 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     140 ;
     141 Q 0
     142 ;
     143INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     144 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     145 ;
     146 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     147 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     148 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     149 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     150 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     151 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     152 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     153 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     154 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     155 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     156 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     157 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     158 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     159 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     160 E  S OCXMON=$E(OCXMON+100,2,3)
     161 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     162 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     163 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     164 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     165 Q OCXMON_" "_OCXDAY_","_OCXYR
     166 ;
     167ORDERER(ORNUM) ;  Compiler Function: ORDERING PROVIDER
     168 ;
     169 Q:'$G(ORNUM) ""
     170 S ORNUM=+$G(ORNUM)
     171 N ORQDUZ,ORQI S ORQDUZ=""
     172 I $L($G(^OR(100,ORNUM,8,0))) D
     173 .S ORQI=0,ORQI=$O(^OR(100,ORNUM,8,"C","NW",ORQI))
     174 Q:+$G(ORQI)<1 ""
     175 S ORQDUZ=$P(^OR(100,ORNUM,8,ORQI,0),U,3)
     176 Q ORQDUZ
     177 ;
     178ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     179 Q:'$G(OIEN) ""
     180 ;
     181 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     182 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     183 Q $P(X,U,1)
     184 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m

    r613 r623  
    1 OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK121  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK2+14^OCXOZ02.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK121 Variables
    19         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    20         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    21         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    22         ;
    23         ;      Local Extrinsic Functions
    24         ; FILE(DFN,101, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 FINAL IMAGING RESULT)
    25         ; FILE(DFN,55, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CONSULT FINAL RESULTS)
    26         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    27         ;
    28         I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,55,"96") Q:OCXOERR
    29         I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,101,"96") Q:OCXOERR
    30         Q
    31         ;
    32 CHK131  ; Look through the current environment for valid Event/Elements for this patient.
    33         ;  Called from CHK12+33^OCXOZ03.
    34         ;
    35         Q:$G(OCXOERR)
    36         ;
    37         ;    Local CHK131 Variables
    38         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    39         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    40         ; OCXDF(54) ---> Data Field: SITE FLAGGED ORDER (BOOLEAN)
    41         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    42         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    43         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    44         ;
    45         ;      Local Extrinsic Functions
    46         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    47         ; PATLOC( ----------> PATIENT LOCATION
    48         ;
    49         S OCXDF(54)=$$SITEORD^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(54)),(OCXDF(54)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK136
    50         Q
    51         ;
    52 CHK136  ; Look through the current environment for valid Event/Elements for this patient.
    53         ;  Called from CHK131+17.
    54         ;
    55         Q:$G(OCXOERR)
    56         ;
    57         ;      Local Extrinsic Functions
    58         ; FILE(DFN,58, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NEW SITE FLAGGED ORDER)
    59         ;
    60         S OCXOERR=$$FILE(DFN,58,"9,96,147") Q:OCXOERR
    61         Q
    62         ;
    63 CHK144  ; Look through the current environment for valid Event/Elements for this patient.
    64         ;  Called from CHK47+20^OCXOZ05.
    65         ;
    66         Q:$G(OCXOERR)
    67         ;
    68         ;    Local CHK144 Variables
    69         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    70         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    71         ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
    72         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    73         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    74         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    75         ;
    76         ;      Local Extrinsic Functions
    77         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    78         ; PATLOC( ----------> PATIENT LOCATION
    79         ;
    80         S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK149
    81         Q
    82         ;
    83 CHK149  ; Look through the current environment for valid Event/Elements for this patient.
    84         ;  Called from CHK144+17.
    85         ;
    86         Q:$G(OCXOERR)
    87         ;
    88         ;      Local Extrinsic Functions
    89         ; FILE(DFN,59, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SITE FLAGGED FINAL LAB RESULT)
    90         ;
    91         S OCXOERR=$$FILE(DFN,59,"9,96,147") Q:OCXOERR
    92         Q
    93         ;
    94 CHK151  ; Look through the current environment for valid Event/Elements for this patient.
    95         ;  Called from CHK1+31^OCXOZ02.
    96         ;
    97         Q:$G(OCXOERR)
    98         ;
    99         ;    Local CHK151 Variables
    100         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    101         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    102         ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
    103         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    104         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    105         ;
    106         ;      Local Extrinsic Functions
    107         ; FILE(DFN,60, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NEW OBR STAT ORDER)
    108         ; LIST( ------------> IN LIST OPERATOR
    109         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    110         ;
    111         I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,60,"96") Q:OCXOERR
    112         I $L(OCXDF(15)),(OCXDF(15)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK264^OCXOZ0B
    113         Q
    114         ;
    115 CHK157  ; Look through the current environment for valid Event/Elements for this patient.
    116         ;  Called from CHK1+32^OCXOZ02.
    117         ;
    118         Q:$G(OCXOERR)
    119         ;
    120         ;    Local CHK157 Variables
    121         ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
    122         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    123         ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
    124         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    125         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    126         ;
    127         ;      Local Extrinsic Functions
    128         ; FILE(DFN,61, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NEW ORC STAT ORDER)
    129         ; LIST( ------------> IN LIST OPERATOR
    130         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    131         ;
    132         I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,61,"96") Q:OCXOERR
    133         I $L(OCXDF(23)),(OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK253^OCXOZ0B
    134         Q
    135         ;
    136 CHK163  ; Look through the current environment for valid Event/Elements for this patient.
    137         ;  Called from CHK58+18^OCXOZ05.
    138         ;
    139         Q:$G(OCXOERR)
    140         ;
    141         ;    Local CHK163 Variables
    142         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    143         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    144         ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT)
    145         ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT)
    146         ;
    147         I (OCXDF(40)="ACCEPT") D CHK164^OCXOZ08
    148         I (OCXDF(40)="DISPLAY") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK182^OCXOZ08
    149         I (OCXDF(40)="SELECT") D CHK196^OCXOZ09
    150         I (OCXDF(40)="SESSION") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) D CHK227^OCXOZ0A
    151         Q
    152         ;
    153 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    154         ;
    155         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    156         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    157         ;
    158         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    159         ;
    160         S OCXDATA(DFN,OCXELE)=1
    161         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    162         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    163         ;
    164         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    165         ;
    166         Q 0
    167         ;
    168 LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
    169         ;
    170         S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
    171         Q (LIST[DATA)
    172         ;
    173 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    174         Q:'$G(OIEN) ""
    175         ;
    176         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    177         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    178         Q $P(X,U,1)
    179         ;
    180 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    181         ;
    182         N OCXP1,OCXP2
    183         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    184         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    185         I OCXP2 D
    186         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    187         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    188         .E  S OCXP2=$P(OCXP2,"^",1)
    189         .S:'$L(OCXP2) OCXP2="NO LOC"
    190         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    191         ;
    192         S OCXP2=$G(^DPT(+$G(DFN),.1))
    193         I $L(OCXP2) Q "I^"_OCXP2
    194         Q "O^OUTPT"
    195         ;
     1OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK121 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK2+14^OCXOZ02.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK121 Variables
     19 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     20 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     21 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     22 ;
     23 ;      Local Extrinsic Functions
     24 ; FILE(DFN,101, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 FINAL IMAGING RESULT)
     25 ; FILE(DFN,55, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CONSULT FINAL RESULTS)
     26 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     27 ;
     28 I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,55,"96") Q:OCXOERR
     29 I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,101,"96") Q:OCXOERR
     30 Q
     31 ;
     32CHK131 ; Look through the current environment for valid Event/Elements for this patient.
     33 ;  Called from CHK12+33^OCXOZ03.
     34 ;
     35 Q:$G(OCXOERR)
     36 ;
     37 ;    Local CHK131 Variables
     38 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     39 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     40 ; OCXDF(54) ---> Data Field: SITE FLAGGED ORDER (BOOLEAN)
     41 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     42 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     43 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     44 ;
     45 ;      Local Extrinsic Functions
     46 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     47 ; PATLOC( ----------> PATIENT LOCATION
     48 ;
     49 S OCXDF(54)=$$SITEORD^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(54)),(OCXDF(54)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK136
     50 Q
     51 ;
     52CHK136 ; Look through the current environment for valid Event/Elements for this patient.
     53 ;  Called from CHK131+17.
     54 ;
     55 Q:$G(OCXOERR)
     56 ;
     57 ;      Local Extrinsic Functions
     58 ; FILE(DFN,58, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NEW SITE FLAGGED ORDER)
     59 ;
     60 S OCXOERR=$$FILE(DFN,58,"9,96,147") Q:OCXOERR
     61 Q
     62 ;
     63CHK144 ; Look through the current environment for valid Event/Elements for this patient.
     64 ;  Called from CHK47+20^OCXOZ05.
     65 ;
     66 Q:$G(OCXOERR)
     67 ;
     68 ;    Local CHK144 Variables
     69 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     70 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     71 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
     72 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     73 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     74 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     75 ;
     76 ;      Local Extrinsic Functions
     77 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     78 ; PATLOC( ----------> PATIENT LOCATION
     79 ;
     80 S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK149
     81 Q
     82 ;
     83CHK149 ; Look through the current environment for valid Event/Elements for this patient.
     84 ;  Called from CHK144+17.
     85 ;
     86 Q:$G(OCXOERR)
     87 ;
     88 ;      Local Extrinsic Functions
     89 ; FILE(DFN,59, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SITE FLAGGED FINAL LAB RESULT)
     90 ;
     91 S OCXOERR=$$FILE(DFN,59,"9,96,147") Q:OCXOERR
     92 Q
     93 ;
     94CHK151 ; Look through the current environment for valid Event/Elements for this patient.
     95 ;  Called from CHK1+31^OCXOZ02.
     96 ;
     97 Q:$G(OCXOERR)
     98 ;
     99 ;    Local CHK151 Variables
     100 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     101 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     102 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT)
     103 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     104 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     105 ;
     106 ;      Local Extrinsic Functions
     107 ; FILE(DFN,60, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NEW OBR STAT ORDER)
     108 ; LIST( ------------> IN LIST OPERATOR
     109 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     110 ;
     111 I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,60,"96") Q:OCXOERR
     112 I $L(OCXDF(15)),(OCXDF(15)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK264^OCXOZ0B
     113 Q
     114 ;
     115CHK157 ; Look through the current environment for valid Event/Elements for this patient.
     116 ;  Called from CHK1+32^OCXOZ02.
     117 ;
     118 Q:$G(OCXOERR)
     119 ;
     120 ;    Local CHK157 Variables
     121 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT)
     122 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     123 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT)
     124 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     125 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     126 ;
     127 ;      Local Extrinsic Functions
     128 ; FILE(DFN,61, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NEW ORC STAT ORDER)
     129 ; LIST( ------------> IN LIST OPERATOR
     130 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     131 ;
     132 I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,61,"96") Q:OCXOERR
     133 I $L(OCXDF(23)),(OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK253^OCXOZ0B
     134 Q
     135 ;
     136CHK163 ; Look through the current environment for valid Event/Elements for this patient.
     137 ;  Called from CHK58+18^OCXOZ05.
     138 ;
     139 Q:$G(OCXOERR)
     140 ;
     141 ;    Local CHK163 Variables
     142 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     143 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     144 ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT)
     145 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT)
     146 ;
     147 I (OCXDF(40)="ACCEPT") D CHK164^OCXOZ08
     148 I (OCXDF(40)="DISPLAY") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK182^OCXOZ08
     149 I (OCXDF(40)="SELECT") D CHK196^OCXOZ09
     150 I (OCXDF(40)="SESSION") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) D CHK227^OCXOZ0A
     151 Q
     152 ;
     153FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     154 ;
     155 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     156 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     157 ;
     158 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     159 ;
     160 S OCXDATA(DFN,OCXELE)=1
     161 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     162 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     163 ;
     164 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     165 ;
     166 Q 0
     167 ;
     168LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
     169 ;
     170 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
     171 Q (LIST[DATA)
     172 ;
     173ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     174 Q:'$G(OIEN) ""
     175 ;
     176 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     177 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     178 Q $P(X,U,1)
     179 ;
     180PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     181 ;
     182 N OCXP1,OCXP2
     183 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     184 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     185 I OCXP2 D
     186 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     187 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     188 .E  S OCXP2=$P(OCXP2,"^",1)
     189 .S:'$L(OCXP2) OCXP2="NO LOC"
     190 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     191 ;
     192 S OCXP2=$G(^DPT(+$G(DFN),.1))
     193 I $L(OCXP2) Q "I^"_OCXP2
     194 Q "O^OUTPT"
     195 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m

    r613 r623  
    1 OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK164  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK163+11^OCXOZ07.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK164 Variables
    19         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    20         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    21         ; OCXDF(59) ---> Data Field: CHOLECYSTOGRAM PROCEDURE FLAG (BOOLEAN)
    22         ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
    23         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    24         ;
    25         ;      Local Extrinsic Functions
    26         ; CH( --------------> IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE
    27         ;
    28         S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(59)=$P($$CH(OCXDF(73)),"^",1) I $L(OCXDF(59)),(OCXDF(59)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK171
    29         S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)) D CHK426^OCXOZ0E
    30         Q
    31         ;
    32 CHK171  ; Look through the current environment for valid Event/Elements for this patient.
    33         ;  Called from CHK164+15.
    34         ;
    35         Q:$G(OCXOERR)
    36         ;
    37         ;    Local CHK171 Variables
    38         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    39         ; OCXDF(60) ---> Data Field: RECENT CHOLECYSTOGRAM FLAG (BOOLEAN)
    40         ; OCXDF(61) ---> Data Field: RECENT CHOLECYSTOGRAM TEXT (FREE TEXT)
    41         ; OCXDF(122) --> Data Field: RECENT CHOLECYSTOGRAM ORDER STATUS (FREE TEXT)
    42         ;
    43         ;      Local Extrinsic Functions
    44         ; RECCH( -----------> RECENT CHOLECYSTOGRAM PREOCEDURE
    45         ; RECCHST( ---------> RECENT CHOLECYSTOGRAM ORDER STATUS
    46         ;
    47         S OCXDF(60)=$P($$RECCH(OCXDF(37),7),"^",1) I $L(OCXDF(60)),(OCXDF(60)) S OCXDF(61)=$P($$RECCH(OCXDF(37),7),"^",3),OCXDF(122)=$P($$RECCHST(OCXDF(37),7),"^",2) D CHK176
    48         Q
    49         ;
    50 CHK176  ; Look through the current environment for valid Event/Elements for this patient.
    51         ;  Called from CHK171+15.
    52         ;
    53         Q:$G(OCXOERR)
    54         ;
    55         ;      Local Extrinsic Functions
    56         ; FILE(DFN,63, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM)
    57         ;
    58         S OCXOERR=$$FILE(DFN,63,"61,122") Q:OCXOERR
    59         Q
    60         ;
    61 CHK182  ; Look through the current environment for valid Event/Elements for this patient.
    62         ;  Called from CHK163+12^OCXOZ07.
    63         ;
    64         Q:$G(OCXOERR)
    65         ;
    66         ;    Local CHK182 Variables
    67         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    68         ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
    69         ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT)
    70         ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC)
    71         ; OCXDF(109) --> Data Field: NUMBER OF MEDS (NUMERIC)
    72         ; OCXDF(123) --> Data Field: POLYPHARMACY (BOOLEAN)
    73         ;
    74         ;      Local Extrinsic Functions
    75         ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED)
    76         ; FILE(DFN,95, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: POLYPHARMACY)
    77         ; FLAB( ------------> FORMATTED LAB RESULTS
    78         ;
    79         S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)),(OCXDF(62)>65) S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") D CHK186
    80         S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2) I $L(OCXDF(76)),(OCXDF(76)<50),(OCXDF(76)>0) D CHK247^OCXOZ0B
    81         S OCXDF(123)=$P($$POLYRX^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(123)),(OCXDF(123)) S OCXDF(109)=$P($$NUMRX^ORKPS(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,95,"109") Q:OCXOERR
    82         Q
    83         ;
    84 CHK186  ; Look through the current environment for valid Event/Elements for this patient.
    85         ;  Called from CHK182+18.
    86         ;
    87         Q:$G(OCXOERR)
    88         ;
    89         ;      Local Extrinsic Functions
    90         ; FILE(DFN,64, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PHARMACY PATIENT OVER 65)
    91         ;
    92         S OCXOERR=$$FILE(DFN,64,"64") Q:OCXOERR
    93         Q
    94         ;
    95 CH(OCXOI)       ;  Compiler Function: IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE
    96         ;
    97         N OCXVAL S OCXVAL=$$CM^ORQQRA(OCXOI) Q:(OCXVAL["C") 1_U_OCXVAL Q 0
    98         ;
    99 CRCL(DFN)       ;  Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
    100         ;
    101         N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
    102         N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
    103         S RSLT="0^<Unavailable>"
    104         S PSCR="^^^^^^0"
    105         D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
    106         Q:'$D(ORW) RSLT
    107         S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
    108         S ABW=ABW/2.2  ;ABW (actual body weight) in kg
    109         D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
    110         Q:'$D(ORH) RSLT
    111         S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
    112         S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
    113         S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
    114         S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
    115         S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
    116         S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D
    117         .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D
    118         ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
    119         ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
    120         S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
    121         S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
    122         ;
    123         S HTGT60=$S(HT>60:(HT-60)*2.3,1:0)  ;if ht > 60 inches
    124         I HTGT60>0 D
    125         .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight
    126         .S BWRATIO=(ABW/IBW)  ;body weight ratio
    127         .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
    128         .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
    129         .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
    130         .E  S ADJBW=LOWBW
    131         I +$G(ADJBW)<1 D
    132         .S ADJBW=ABW
    133         S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
    134         ;
    135         S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
    136         S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
    137         Q RSLT
    138         ;
    139 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    140         ;
    141         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    142         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    143         ;
    144         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    145         ;
    146         S OCXDATA(DFN,OCXELE)=1
    147         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    148         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    149         ;
    150         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    151         ;
    152         Q 0
    153         ;
    154 FLAB(DFN,OCXLIST,OCXSPEC)       ;  Compiler Function: FORMATTED LAB RESULTS
    155         ;
    156         Q:'$G(DFN) "<Patient Not Specified>"
    157         Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
    158         N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
    159         I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
    160         F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
    161         .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
    162         .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
    163         .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
    164         ..I $L($G(OCXSL)) D
    165         ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
    166         ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
    167         .....S OCXA($P(OCXX,U,7))=OCXX
    168         ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
    169         ..Q:'$L(OCXX)
    170         .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
    171         .I $L(OCXX) D
    172         ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
    173         ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
    174         ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
    175         .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
    176         Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
    177         ;
    178 RECCH(DFN,DAYS) ;  Compiler Function: RECENT CHOLECYSTOGRAM PREOCEDURE
    179         ;
    180         Q:'$G(DFN) 0 Q:'$G(DAYS) 0 N OUT S OUT=$$RECENTCH^ORKRA(DFN,DAYS) Q:'$L(OUT) 0 Q 1_U_OUT
    181         ;
    182 RECCHST(DFN,DAYS)           ;  Compiler Function: RECENT CHOLECYSTOGRAM ORDER STATUS
    183         ;
    184         Q:'$G(DFN) 0 Q:'$G(DAYS) 0
    185         N ORDER S ORDER=$P($$RECENTCH^ORKRA(DFN,DAYS),U) Q:'$L(ORDER) 0
    186         N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0
    187         Q 1_U_STATUS
    188         ;
    189 TERMLKUP(OCXTERM,OCXLIST)       ;
    190         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    191         ;
     1OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK164 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK163+11^OCXOZ07.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK164 Variables
     19 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     20 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     21 ; OCXDF(59) ---> Data Field: CHOLECYSTOGRAM PROCEDURE FLAG (BOOLEAN)
     22 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
     23 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     24 ;
     25 ;      Local Extrinsic Functions
     26 ; CH( --------------> IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE
     27 ;
     28 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(59)=$P($$CH(OCXDF(73)),"^",1) I $L(OCXDF(59)),(OCXDF(59)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK171
     29 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)) D CHK434^OCXOZ0E
     30 Q
     31 ;
     32CHK171 ; Look through the current environment for valid Event/Elements for this patient.
     33 ;  Called from CHK164+15.
     34 ;
     35 Q:$G(OCXOERR)
     36 ;
     37 ;    Local CHK171 Variables
     38 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     39 ; OCXDF(60) ---> Data Field: RECENT CHOLECYSTOGRAM FLAG (BOOLEAN)
     40 ; OCXDF(61) ---> Data Field: RECENT CHOLECYSTOGRAM TEXT (FREE TEXT)
     41 ; OCXDF(122) --> Data Field: RECENT CHOLECYSTOGRAM ORDER STATUS (FREE TEXT)
     42 ;
     43 ;      Local Extrinsic Functions
     44 ; RECCH( -----------> RECENT CHOLECYSTOGRAM PREOCEDURE
     45 ; RECCHST( ---------> RECENT CHOLECYSTOGRAM ORDER STATUS
     46 ;
     47 S OCXDF(60)=$P($$RECCH(OCXDF(37),7),"^",1) I $L(OCXDF(60)),(OCXDF(60)) S OCXDF(61)=$P($$RECCH(OCXDF(37),7),"^",3),OCXDF(122)=$P($$RECCHST(OCXDF(37),7),"^",2) D CHK176
     48 Q
     49 ;
     50CHK176 ; Look through the current environment for valid Event/Elements for this patient.
     51 ;  Called from CHK171+15.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;      Local Extrinsic Functions
     56 ; FILE(DFN,63, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM)
     57 ;
     58 S OCXOERR=$$FILE(DFN,63,"61,122") Q:OCXOERR
     59 Q
     60 ;
     61CHK182 ; Look through the current environment for valid Event/Elements for this patient.
     62 ;  Called from CHK163+12^OCXOZ07.
     63 ;
     64 Q:$G(OCXOERR)
     65 ;
     66 ;    Local CHK182 Variables
     67 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     68 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
     69 ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT)
     70 ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC)
     71 ; OCXDF(109) --> Data Field: NUMBER OF MEDS (NUMERIC)
     72 ; OCXDF(123) --> Data Field: POLYPHARMACY (BOOLEAN)
     73 ;
     74 ;      Local Extrinsic Functions
     75 ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED)
     76 ; FILE(DFN,95, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: POLYPHARMACY)
     77 ; FLAB( ------------> FORMATTED LAB RESULTS
     78 ;
     79 S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)),(OCXDF(62)>65) S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") D CHK186
     80 S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2) I $L(OCXDF(76)),(OCXDF(76)<50),(OCXDF(76)>0) D CHK247^OCXOZ0B
     81 S OCXDF(123)=$P($$POLYRX^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(123)),(OCXDF(123)) S OCXDF(109)=$P($$NUMRX^ORKPS(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,95,"109") Q:OCXOERR
     82 Q
     83 ;
     84CHK186 ; Look through the current environment for valid Event/Elements for this patient.
     85 ;  Called from CHK182+18.
     86 ;
     87 Q:$G(OCXOERR)
     88 ;
     89 ;      Local Extrinsic Functions
     90 ; FILE(DFN,64, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PHARMACY PATIENT OVER 65)
     91 ;
     92 S OCXOERR=$$FILE(DFN,64,"64") Q:OCXOERR
     93 Q
     94 ;
     95CH(OCXOI) ;  Compiler Function: IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE
     96 ;
     97 N OCXVAL S OCXVAL=$$CM^ORQQRA(OCXOI) Q:(OCXVAL["C") 1_U_OCXVAL Q 0
     98 ;
     99CRCL(DFN) ;  Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
     100 ;
     101 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
     102 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
     103 S RSLT="0^<Unavailable>"
     104 S PSCR="^^^^^^0"
     105 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
     106 Q:'$D(ORW) RSLT
     107 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
     108 S ABW=ABW/2.2  ;ABW (actual body weight) in kg
     109 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
     110 Q:'$D(ORH) RSLT
     111 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
     112 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
     113 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
     114 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
     115 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
     116 S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D
     117 .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D
     118 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
     119 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
     120 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
     121 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
     122 ;
     123 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0)  ;if ht > 60 inches
     124 I HTGT60>0 D
     125 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight
     126 .S BWRATIO=(ABW/IBW)  ;body weight ratio
     127 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
     128 .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
     129 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
     130 .E  S ADJBW=LOWBW
     131 I +$G(ADJBW)<1 D
     132 .S ADJBW=ABW
     133 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
     134 ;
     135 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
     136 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
     137 Q RSLT
     138 ;
     139FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     140 ;
     141 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     142 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     143 ;
     144 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     145 ;
     146 S OCXDATA(DFN,OCXELE)=1
     147 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     148 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     149 ;
     150 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     151 ;
     152 Q 0
     153 ;
     154FLAB(DFN,OCXLIST,OCXSPEC) ;  Compiler Function: FORMATTED LAB RESULTS
     155 ;
     156 Q:'$G(DFN) "<Patient Not Specified>"
     157 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
     158 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
     159 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
     160 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
     161 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
     162 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
     163 .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
     164 ..I $L($G(OCXSL)) D
     165 ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
     166 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
     167 .....S OCXA($P(OCXX,U,7))=OCXX
     168 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
     169 ..Q:'$L(OCXX)
     170 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
     171 .I $L(OCXX) D
     172 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
     173 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
     174 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
     175 .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
     176 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
     177 ;
     178RECCH(DFN,DAYS) ;  Compiler Function: RECENT CHOLECYSTOGRAM PREOCEDURE
     179 ;
     180 Q:'$G(DFN) 0 Q:'$G(DAYS) 0 N OUT S OUT=$$RECENTCH^ORKRA(DFN,DAYS) Q:'$L(OUT) 0 Q 1_U_OUT
     181 ;
     182RECCHST(DFN,DAYS)     ;  Compiler Function: RECENT CHOLECYSTOGRAM ORDER STATUS
     183 ;
     184 Q:'$G(DFN) 0 Q:'$G(DAYS) 0
     185 N ORDER S ORDER=$P($$RECENTCH^ORKRA(DFN,DAYS),U) Q:'$L(ORDER) 0
     186 N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0
     187 Q 1_U_STATUS
     188 ;
     189TERMLKUP(OCXTERM,OCXLIST) ;
     190 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     191 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m

    r613 r623  
    1 OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK188  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK58+19^OCXOZ05.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK188 Variables
    19         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    20         ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT)
    21         ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT)
    22         ;
    23         ;      Local Extrinsic Functions
    24         ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
    25         ; EQTERM( ----------> EQUALS TERM OPERATOR
    26         ;
    27         I $$EQTERM(OCXDF(47),"ANGIOGRAM (PERIPHERAL)") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SESSION") D CHK192
    28         I $$CLIST(OCXDF(47),"GLUCOPHAGE,METFORMIN") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SELECT") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK280^OCXOZ0B
    29         Q
    30         ;
    31 CHK192  ; Look through the current environment for valid Event/Elements for this patient.
    32         ;  Called from CHK188+14.
    33         ;
    34         Q:$G(OCXOERR)
    35         ;
    36         ;    Local CHK192 Variables
    37         ; OCXDF(68) ---> Data Field: MISSING ANGIOGRAM, CATH PERIF LAB TESTS (FREE TEXT)
    38         ;
    39         ;      Local Extrinsic Functions
    40         ; FILE(DFN,65, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SESSION ORDER FOR ANGIOGRAM)
    41         ; MTSTF( -----------> MISSING TESTS DURING SESSION
    42         ;
    43         S OCXDF(68)=$$MTSTF("PROTHROMBIN TIME,PARTIAL THROMBOPLASTIN TIME") I $L(OCXDF(68)),($L(OCXDF(68))>0) S OCXOERR=$$FILE(DFN,65,"68") Q:OCXOERR
    44         Q
    45         ;
    46 CHK196  ; Look through the current environment for valid Event/Elements for this patient.
    47         ;  Called from CHK163+13^OCXOZ07.
    48         ;
    49         Q:$G(OCXOERR)
    50         ;
    51         ;    Local CHK196 Variables
    52         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    53         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    54         ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
    55         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    56         ; OCXDF(156) --> Data Field: ALLERGY ASSESSMENT (BOOLEAN)
    57         ;
    58         ;      Local Extrinsic Functions
    59         ; ALRGY( -----------> ALLERGY ASSESSMENT
    60         ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
    61         ; FILE(DFN,136, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NO ALLERGY ASSESSMENT)
    62         ;
    63         S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK198
    64         S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK458^OCXOZ0F
    65         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(156)=$$ALRGY(OCXDF(37)) I $L(OCXDF(156)),'(OCXDF(156)) S OCXOERR=$$FILE(DFN,136,"") Q:OCXOERR
    66         Q
    67         ;
    68 CHK198  ; Look through the current environment for valid Event/Elements for this patient.
    69         ;  Called from CHK196+17.
    70         ;
    71         Q:$G(OCXOERR)
    72         ;
    73         ;    Local CHK198 Variables
    74         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    75         ;
    76         I (OCXDF(2)="RA") D CHK199
    77         I ($E(OCXDF(2),1,2)="PS") D CHK360^OCXOZ0D
    78         Q
    79         ;
    80 CHK199  ; Look through the current environment for valid Event/Elements for this patient.
    81         ;  Called from CHK198+8.
    82         ;
    83         Q:$G(OCXOERR)
    84         ;
    85         ;    Local CHK199 Variables
    86         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    87         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    88         ;
    89         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK201
    90         S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) D CHK236^OCXOZ0A
    91         Q
    92         ;
    93 CHK201  ; Look through the current environment for valid Event/Elements for this patient.
    94         ;  Called from CHK199+9.
    95         ;
    96         Q:$G(OCXOERR)
    97         ;
    98         ;    Local CHK201 Variables
    99         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    100         ; OCXDF(65) ---> Data Field: CONTRAST MEDIA ALLERGY FLAG (BOOLEAN)
    101         ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
    102         ; OCXDF(69) ---> Data Field: RECENT BARIUM STUDY FLAG (BOOLEAN)
    103         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    104         ;
    105         ;      Local Extrinsic Functions
    106         ; RECBAR( ----------> RECENT BARIUM STUDY
    107         ;
    108         S OCXDF(65)=$$ORCHK^GMRAOR(OCXDF(37),"CM","") I $L(OCXDF(65)),(OCXDF(65)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK207
    109         S OCXDF(69)=$P($$RECBAR(OCXDF(37),48),"^",1) I $L(OCXDF(69)),(OCXDF(69)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK217^OCXOZ0A
    110         Q
    111         ;
    112 CHK207  ; Look through the current environment for valid Event/Elements for this patient.
    113         ;  Called from CHK201+15.
    114         ;
    115         Q:$G(OCXOERR)
    116         ;
    117         ;    Local CHK207 Variables
    118         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    119         ; OCXDF(66) ---> Data Field: CONTRAST MEDIA CODE TRANSLATION (FREE TEXT)
    120         ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
    121         ; OCXDF(159) --> Data Field: ALLERGY CONTRAST MEDIA LOCATION (FREE TEXT)
    122         ;
    123         ;      Local Extrinsic Functions
    124         ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
    125         ; CONTRANS( --------> CONTRAST MEDIA CODE TRANSLATION
    126         ;
    127         I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N,L,C,G,B") S OCXDF(66)=$$CONTRANS(OCXDF(67)),OCXDF(159)=$P($$ORCHK^GMRAOR(OCXDF(37),"CM","",1),"^",2) D CHK211
    128         Q
    129         ;
    130 CHK211  ; Look through the current environment for valid Event/Elements for this patient.
    131         ;  Called from CHK207+15.
    132         ;
    133         Q:$G(OCXOERR)
    134         ;
    135         ;      Local Extrinsic Functions
    136         ; FILE(DFN,66, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CONTRAST MEDIA ALLERGY)
    137         ;
    138         S OCXOERR=$$FILE(DFN,66,"66,159") Q:OCXOERR
    139         Q
    140         ;
    141 ALRGY(ORPT)       ; determine if pt has an allergy assessment
    142         ; rtn 0 if no allergy assessment, 1 if allergy assessment or NKA
    143         N ORALRGY
    144         D EN1^GMRAOR1(ORPT,"ORALRGY")
    145         Q:$G(ORALRGY)="" 0
    146         Q 1
    147         ;
    148 CLIST(DATA,LIST)        ;   DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST
    149         ;
    150         N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q
    151         Q ''PC
    152         ;
    153 CONTRANS(OCXC)  ;  Compiler Function: CONTRAST MEDIA CODE TRANSLATION
    154         ;
    155         N OCXX
    156         Q:'$L($G(OCXC)) "" S OCXX=$S((OCXC["B"):"Barium",1:"")
    157         I (OCXC["G") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gastrografin"
    158         I (OCXC["I") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Ionic Iodinated"
    159         I (OCXC["N") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Non-ionic Iodinated"
    160         I (OCXC["L") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gadolinium"
    161         I (OCXC["C") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Cholecystographic"
    162         I (OCXC["M") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Unspecified contrast media"
    163         Q OCXX
    164         ;
    165 EQTERM(DATA,TERM)       ;  Compiler Function: EQUALS TERM OPERATOR
    166         ;
    167         N OCXF,OCXL
    168         ;
    169         S OCXL="",OCXF=$$TERMLKUP(TERM,.OCXL)
    170         Q:'OCXF 0
    171         I ($D(OCXL(DATA))!$D(OCXL("B",DATA))) Q 1
    172         Q 0
    173         ;
    174 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    175         ;
    176         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    177         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    178         ;
    179         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    180         ;
    181         S OCXDATA(DFN,OCXELE)=1
    182         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    183         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    184         ;
    185         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    186         ;
    187         Q 0
    188         ;
    189 MTSTF(OILIST)   ;  Compiler Function: MISSING TESTS DURING SESSION
    190         ;
    191         N OCXPC,OCXOI,OCXOUT S OCXOUT=""
    192         F OCXPC=1:1:$L(OILIST,",") S OCXOI=$P(OILIST,",",OCXPC) I $L(OCXOI) D
    193         .N OCXL,OCXF,OCXD0
    194         .S OCXL="",OCXF=$$TERMLKUP(OCXOI,.OCXL)
    195         .S OCXD0=0 F  S OCXD0=$O(OCXL(OCXD0)) Q:'OCXD0  Q:$$OISESS^ORKCHK2(+OCXD0)
    196         .Q:OCXD0
    197         .S:$L(OCXOUT) OCXOUT=OCXOUT_", " S OCXOUT=OCXOUT_OCXOI
    198         Q OCXOUT
    199         ;
    200 RECBAR(DFN,HOURS)       ;  Compiler Function: RECENT BARIUM STUDY
    201         ;
    202         Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT
    203         ; 
    204         ;
    205 TERMLKUP(OCXTERM,OCXLIST)       ;
    206         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    207         ;
     1OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK188 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK58+19^OCXOZ05.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK188 Variables
     19 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     20 ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT)
     21 ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT)
     22 ;
     23 ;      Local Extrinsic Functions
     24 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
     25 ; EQTERM( ----------> EQUALS TERM OPERATOR
     26 ;
     27 I $$EQTERM(OCXDF(47),"ANGIOGRAM (PERIPHERAL)") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SESSION") D CHK192
     28 I $$CLIST(OCXDF(47),"GLUCOPHAGE,METFORMIN") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SELECT") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK280^OCXOZ0B
     29 Q
     30 ;
     31CHK192 ; Look through the current environment for valid Event/Elements for this patient.
     32 ;  Called from CHK188+14.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 ;    Local CHK192 Variables
     37 ; OCXDF(68) ---> Data Field: MISSING ANGIOGRAM, CATH PERIF LAB TESTS (FREE TEXT)
     38 ;
     39 ;      Local Extrinsic Functions
     40 ; FILE(DFN,65, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SESSION ORDER FOR ANGIOGRAM)
     41 ; MTSTF( -----------> MISSING TESTS DURING SESSION
     42 ;
     43 S OCXDF(68)=$$MTSTF("PROTHROMBIN TIME,PARTIAL THROMBOPLASTIN TIME") I $L(OCXDF(68)),($L(OCXDF(68))>0) S OCXOERR=$$FILE(DFN,65,"68") Q:OCXOERR
     44 Q
     45 ;
     46CHK196 ; Look through the current environment for valid Event/Elements for this patient.
     47 ;  Called from CHK163+13^OCXOZ07.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 ;    Local CHK196 Variables
     52 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     53 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     54 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
     55 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     56 ; OCXDF(156) --> Data Field: ALLERGY ASSESSMENT (BOOLEAN)
     57 ;
     58 ;      Local Extrinsic Functions
     59 ; ALRGY( -----------> ALLERGY ASSESSMENT
     60 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
     61 ; FILE(DFN,136, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NO ALLERGY ASSESSMENT)
     62 ;
     63 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK198
     64 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK466^OCXOZ0F
     65 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(156)=$$ALRGY(OCXDF(37)) I $L(OCXDF(156)),'(OCXDF(156)) S OCXOERR=$$FILE(DFN,136,"") Q:OCXOERR
     66 Q
     67 ;
     68CHK198 ; Look through the current environment for valid Event/Elements for this patient.
     69 ;  Called from CHK196+17.
     70 ;
     71 Q:$G(OCXOERR)
     72 ;
     73 ;    Local CHK198 Variables
     74 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     75 ;
     76 I (OCXDF(2)="RA") D CHK199
     77 I ($E(OCXDF(2),1,2)="PS") D CHK362^OCXOZ0D
     78 Q
     79 ;
     80CHK199 ; Look through the current environment for valid Event/Elements for this patient.
     81 ;  Called from CHK198+8.
     82 ;
     83 Q:$G(OCXOERR)
     84 ;
     85 ;    Local CHK199 Variables
     86 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     87 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     88 ;
     89 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK201
     90 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) D CHK236^OCXOZ0A
     91 Q
     92 ;
     93CHK201 ; Look through the current environment for valid Event/Elements for this patient.
     94 ;  Called from CHK199+9.
     95 ;
     96 Q:$G(OCXOERR)
     97 ;
     98 ;    Local CHK201 Variables
     99 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     100 ; OCXDF(65) ---> Data Field: CONTRAST MEDIA ALLERGY FLAG (BOOLEAN)
     101 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
     102 ; OCXDF(69) ---> Data Field: RECENT BARIUM STUDY FLAG (BOOLEAN)
     103 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     104 ;
     105 ;      Local Extrinsic Functions
     106 ; RECBAR( ----------> RECENT BARIUM STUDY
     107 ;
     108 S OCXDF(65)=$$ORCHK^GMRAOR(OCXDF(37),"CM","") I $L(OCXDF(65)),(OCXDF(65)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK207
     109 S OCXDF(69)=$P($$RECBAR(OCXDF(37),48),"^",1) I $L(OCXDF(69)),(OCXDF(69)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK217^OCXOZ0A
     110 Q
     111 ;
     112CHK207 ; Look through the current environment for valid Event/Elements for this patient.
     113 ;  Called from CHK201+15.
     114 ;
     115 Q:$G(OCXOERR)
     116 ;
     117 ;    Local CHK207 Variables
     118 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     119 ; OCXDF(66) ---> Data Field: CONTRAST MEDIA CODE TRANSLATION (FREE TEXT)
     120 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
     121 ; OCXDF(159) --> Data Field: ALLERGY CONTRAST MEDIA LOCATION (FREE TEXT)
     122 ;
     123 ;      Local Extrinsic Functions
     124 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
     125 ; CONTRANS( --------> CONTRAST MEDIA CODE TRANSLATION
     126 ;
     127 I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N,L,C,G,B") S OCXDF(66)=$$CONTRANS(OCXDF(67)),OCXDF(159)=$P($$ORCHK^GMRAOR(OCXDF(37),"CM","",1),"^",2) D CHK211
     128 Q
     129 ;
     130CHK211 ; Look through the current environment for valid Event/Elements for this patient.
     131 ;  Called from CHK207+15.
     132 ;
     133 Q:$G(OCXOERR)
     134 ;
     135 ;      Local Extrinsic Functions
     136 ; FILE(DFN,66, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CONTRAST MEDIA ALLERGY)
     137 ;
     138 S OCXOERR=$$FILE(DFN,66,"66,159") Q:OCXOERR
     139 Q
     140 ;
     141ALRGY(ORPT)   ; determine if pt has an allergy assessment
     142 ; rtn 0 if no allergy assessment, 1 if allergy assessment or NKA
     143 N ORALRGY
     144 D EN1^GMRAOR1(ORPT,"ORALRGY")
     145 Q:$G(ORALRGY)="" 0
     146 Q 1
     147 ;
     148CLIST(DATA,LIST) ;   DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST
     149 ;
     150 N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q
     151 Q ''PC
     152 ;
     153CONTRANS(OCXC) ;  Compiler Function: CONTRAST MEDIA CODE TRANSLATION
     154 ;
     155 N OCXX
     156 Q:'$L($G(OCXC)) "" S OCXX=$S((OCXC["B"):"Barium",1:"")
     157 I (OCXC["G") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gastrografin"
     158 I (OCXC["I") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Ionic Iodinated"
     159 I (OCXC["N") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Non-ionic Iodinated"
     160 I (OCXC["L") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gadolinium"
     161 I (OCXC["C") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Cholecystographic"
     162 I (OCXC["M") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Unspecified contrast media"
     163 Q OCXX
     164 ;
     165EQTERM(DATA,TERM) ;  Compiler Function: EQUALS TERM OPERATOR
     166 ;
     167 N OCXF,OCXL
     168 ;
     169 S OCXL="",OCXF=$$TERMLKUP(TERM,.OCXL)
     170 Q:'OCXF 0
     171 I ($D(OCXL(DATA))!$D(OCXL("B",DATA))) Q 1
     172 Q 0
     173 ;
     174FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     175 ;
     176 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     177 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     178 ;
     179 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     180 ;
     181 S OCXDATA(DFN,OCXELE)=1
     182 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     183 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     184 ;
     185 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     186 ;
     187 Q 0
     188 ;
     189MTSTF(OILIST) ;  Compiler Function: MISSING TESTS DURING SESSION
     190 ;
     191 N OCXPC,OCXOI,OCXOUT S OCXOUT=""
     192 F OCXPC=1:1:$L(OILIST,",") S OCXOI=$P(OILIST,",",OCXPC) I $L(OCXOI) D
     193 .N OCXL,OCXF,OCXD0
     194 .S OCXL="",OCXF=$$TERMLKUP(OCXOI,.OCXL)
     195 .S OCXD0=0 F  S OCXD0=$O(OCXL(OCXD0)) Q:'OCXD0  Q:$$OISESS^ORKCHK2(+OCXD0)
     196 .Q:OCXD0
     197 .S:$L(OCXOUT) OCXOUT=OCXOUT_", " S OCXOUT=OCXOUT_OCXOI
     198 Q OCXOUT
     199 ;
     200RECBAR(DFN,HOURS) ;  Compiler Function: RECENT BARIUM STUDY
     201 ;
     202 Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT
     203 ; 
     204 ;
     205TERMLKUP(OCXTERM,OCXLIST) ;
     206 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     207 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m

    r613 r623  
    1 OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK217  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK201+16^OCXOZ09.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK217 Variables
    19         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    20         ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
    21         ; OCXDF(70) ---> Data Field: RECENT BARIUM STUDY TEXT (FREE TEXT)
    22         ; OCXDF(121) --> Data Field: RECENT BARIUM STUDY ORDER STATUS (FREE TEXT)
    23         ;
    24         ;      Local Extrinsic Functions
    25         ; FILE(DFN,67, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RECENT BARIUM STUDY ORDERED)
    26         ; RECBAR( ----------> RECENT BARIUM STUDY
    27         ; RECBARST( --------> RECENT BARIUM ORDER STATUS
    28         ;
    29         I $L(OCXDF(67)),(OCXDF(67)["B") S OCXDF(70)=$P($$RECBAR(OCXDF(37),48),"^",3),OCXDF(121)=$P($$RECBARST(OCXDF(37),48),"^",2),OCXOERR=$$FILE(DFN,67,"70,121") Q:OCXOERR
    30         Q
    31         ;
    32 CHK227  ; Look through the current environment for valid Event/Elements for this patient.
    33         ;  Called from CHK163+14^OCXOZ07.
    34         ;
    35         Q:$G(OCXOERR)
    36         ;
    37         ;    Local CHK227 Variables
    38         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    39         ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT)
    40         ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT)
    41         ;
    42         ;      Local Extrinsic Functions
    43         ;
    44         S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)),(OCXDF(74)="AMINOGLYCOSIDES") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK232
    45         Q
    46         ;
    47 CHK232  ; Look through the current environment for valid Event/Elements for this patient.
    48         ;  Called from CHK227+12.
    49         ;
    50         Q:$G(OCXOERR)
    51         ;
    52         ;    Local CHK232 Variables
    53         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    54         ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT)
    55         ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC)
    56         ;
    57         ;      Local Extrinsic Functions
    58         ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED)
    59         ; FILE(DFN,71, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: AMINOGLYCOSIDE ORDER SESSION)
    60         ; FLAB( ------------> FORMATTED LAB RESULTS
    61         ;
    62         S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,71,"64,76") Q:OCXOERR
    63         Q
    64         ;
    65 CHK236  ; Look through the current environment for valid Event/Elements for this patient.
    66         ;  Called from CHK199+10^OCXOZ09.
    67         ;
    68         Q:$G(OCXOERR)
    69         ;
    70         ;    Local CHK236 Variables
    71         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    72         ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
    73         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    74         ; OCXDF(78) ---> Data Field: PATIENT TOO BIG FOR SCANNER FLAG (BOOLEAN)
    75         ;
    76         ;      Local Extrinsic Functions
    77         ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
    78         ; CTMRI( -----------> CT MRI PHYSICAL LIMITS
    79         ; FILE(DFN,106, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA)
    80         ;
    81         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(78)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",1) I $L(OCXDF(78)),(OCXDF(78)) D CHK241^OCXOZ0B
    82         S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXOERR=$$FILE(DFN,106,"") Q:OCXOERR
    83         Q
    84         ;
    85 CLIST(DATA,LIST)        ;   DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST
    86         ;
    87         N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q
    88         Q ''PC
    89         ;
    90 CRCL(DFN)       ;  Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
    91         ;
    92         N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
    93         N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
    94         S RSLT="0^<Unavailable>"
    95         S PSCR="^^^^^^0"
    96         D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
    97         Q:'$D(ORW) RSLT
    98         S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
    99         S ABW=ABW/2.2  ;ABW (actual body weight) in kg
    100         D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
    101         Q:'$D(ORH) RSLT
    102         S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
    103         S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
    104         S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
    105         S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
    106         S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
    107         S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D
    108         .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D
    109         ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
    110         ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
    111         S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
    112         S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
    113         ;
    114         S HTGT60=$S(HT>60:(HT-60)*2.3,1:0)  ;if ht > 60 inches
    115         I HTGT60>0 D
    116         .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight
    117         .S BWRATIO=(ABW/IBW)  ;body weight ratio
    118         .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
    119         .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
    120         .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
    121         .E  S ADJBW=LOWBW
    122         I +$G(ADJBW)<1 D
    123         .S ADJBW=ABW
    124         S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
    125         ;
    126         S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
    127         S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
    128         Q RSLT
    129         ;
    130 CTMRI(DFN,OCXOI)        ;  Compiler Function: CT MRI PHYSICAL LIMITS
    131         ;
    132         N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL
    133         S OCXDEV=$$TYPE^ORKRA(OCXOI)
    134         Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U
    135         S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2)
    136         I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q")
    137         I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner"
    138         I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner"
    139         I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q")
    140         I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner"
    141         I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner"
    142         Q 0_U
    143         ;
    144 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    145         ;
    146         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    147         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    148         ;
    149         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    150         ;
    151         S OCXDATA(DFN,OCXELE)=1
    152         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    153         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    154         ;
    155         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    156         ;
    157         Q 0
    158         ;
    159 FLAB(DFN,OCXLIST,OCXSPEC)       ;  Compiler Function: FORMATTED LAB RESULTS
    160         ;
    161         Q:'$G(DFN) "<Patient Not Specified>"
    162         Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
    163         N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
    164         I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
    165         F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
    166         .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
    167         .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
    168         .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
    169         ..I $L($G(OCXSL)) D
    170         ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
    171         ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
    172         .....S OCXA($P(OCXX,U,7))=OCXX
    173         ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
    174         ..Q:'$L(OCXX)
    175         .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
    176         .I $L(OCXX) D
    177         ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
    178         ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
    179         ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
    180         .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
    181         Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
    182         ;
    183 RECBAR(DFN,HOURS)       ;  Compiler Function: RECENT BARIUM STUDY
    184         ;
    185         Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT
    186         ; 
    187         ;
    188 RECBARST(DFN,HOURS)        ;  Compiler Function: RECENT BARIUM ORDER STATUS
    189         ;
    190         Q:'$G(DFN) 0 Q:'$G(HOURS) 0
    191         N ORDER S ORDER=$P($$RECENTBA^ORKRA(DFN,HOURS),U) Q:'$L(ORDER) 0
    192         N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0
    193         Q 1_U_STATUS
    194         ;
    195 TERMLKUP(OCXTERM,OCXLIST)       ;
    196         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    197         ;
     1OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK217 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK201+16^OCXOZ09.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK217 Variables
     19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     20 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
     21 ; OCXDF(70) ---> Data Field: RECENT BARIUM STUDY TEXT (FREE TEXT)
     22 ; OCXDF(121) --> Data Field: RECENT BARIUM STUDY ORDER STATUS (FREE TEXT)
     23 ;
     24 ;      Local Extrinsic Functions
     25 ; FILE(DFN,67, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RECENT BARIUM STUDY ORDERED)
     26 ; RECBAR( ----------> RECENT BARIUM STUDY
     27 ; RECBARST( --------> RECENT BARIUM ORDER STATUS
     28 ;
     29 I $L(OCXDF(67)),(OCXDF(67)["B") S OCXDF(70)=$P($$RECBAR(OCXDF(37),48),"^",3),OCXDF(121)=$P($$RECBARST(OCXDF(37),48),"^",2),OCXOERR=$$FILE(DFN,67,"70,121") Q:OCXOERR
     30 Q
     31 ;
     32CHK227 ; Look through the current environment for valid Event/Elements for this patient.
     33 ;  Called from CHK163+14^OCXOZ07.
     34 ;
     35 Q:$G(OCXOERR)
     36 ;
     37 ;    Local CHK227 Variables
     38 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     39 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT)
     40 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT)
     41 ;
     42 ;      Local Extrinsic Functions
     43 ;
     44 S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)),(OCXDF(74)="AMINOGLYCOSIDES") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK232
     45 Q
     46 ;
     47CHK232 ; Look through the current environment for valid Event/Elements for this patient.
     48 ;  Called from CHK227+12.
     49 ;
     50 Q:$G(OCXOERR)
     51 ;
     52 ;    Local CHK232 Variables
     53 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     54 ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT)
     55 ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC)
     56 ;
     57 ;      Local Extrinsic Functions
     58 ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED)
     59 ; FILE(DFN,71, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: AMINOGLYCOSIDE ORDER SESSION)
     60 ; FLAB( ------------> FORMATTED LAB RESULTS
     61 ;
     62 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,71,"64,76") Q:OCXOERR
     63 Q
     64 ;
     65CHK236 ; Look through the current environment for valid Event/Elements for this patient.
     66 ;  Called from CHK199+10^OCXOZ09.
     67 ;
     68 Q:$G(OCXOERR)
     69 ;
     70 ;    Local CHK236 Variables
     71 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     72 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT)
     73 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     74 ; OCXDF(78) ---> Data Field: PATIENT TOO BIG FOR SCANNER FLAG (BOOLEAN)
     75 ;
     76 ;      Local Extrinsic Functions
     77 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES
     78 ; CTMRI( -----------> CT MRI PHYSICAL LIMITS
     79 ; FILE(DFN,106, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA)
     80 ;
     81 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(78)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",1) I $L(OCXDF(78)),(OCXDF(78)) D CHK241^OCXOZ0B
     82 S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXOERR=$$FILE(DFN,106,"") Q:OCXOERR
     83 Q
     84 ;
     85CLIST(DATA,LIST) ;   DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST
     86 ;
     87 N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q
     88 Q ''PC
     89 ;
     90CRCL(DFN) ;  Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
     91 ;
     92 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
     93 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
     94 S RSLT="0^<Unavailable>"
     95 S PSCR="^^^^^^0"
     96 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
     97 Q:'$D(ORW) RSLT
     98 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
     99 S ABW=ABW/2.2  ;ABW (actual body weight) in kg
     100 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
     101 Q:'$D(ORH) RSLT
     102 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
     103 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
     104 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
     105 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
     106 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
     107 S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D
     108 .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D
     109 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
     110 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
     111 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
     112 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
     113 ;
     114 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0)  ;if ht > 60 inches
     115 I HTGT60>0 D
     116 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight
     117 .S BWRATIO=(ABW/IBW)  ;body weight ratio
     118 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
     119 .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
     120 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
     121 .E  S ADJBW=LOWBW
     122 I +$G(ADJBW)<1 D
     123 .S ADJBW=ABW
     124 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
     125 ;
     126 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
     127 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
     128 Q RSLT
     129 ;
     130CTMRI(DFN,OCXOI) ;  Compiler Function: CT MRI PHYSICAL LIMITS
     131 ;
     132 N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL
     133 S OCXDEV=$$TYPE^ORKRA(OCXOI)
     134 Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U
     135 S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2)
     136 I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q")
     137 I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner"
     138 I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner"
     139 I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q")
     140 I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner"
     141 I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner"
     142 Q 0_U
     143 ;
     144FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     145 ;
     146 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     147 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     148 ;
     149 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     150 ;
     151 S OCXDATA(DFN,OCXELE)=1
     152 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     153 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     154 ;
     155 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     156 ;
     157 Q 0
     158 ;
     159FLAB(DFN,OCXLIST,OCXSPEC) ;  Compiler Function: FORMATTED LAB RESULTS
     160 ;
     161 Q:'$G(DFN) "<Patient Not Specified>"
     162 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
     163 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
     164 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
     165 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
     166 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
     167 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
     168 .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
     169 ..I $L($G(OCXSL)) D
     170 ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
     171 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
     172 .....S OCXA($P(OCXX,U,7))=OCXX
     173 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
     174 ..Q:'$L(OCXX)
     175 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
     176 .I $L(OCXX) D
     177 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
     178 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
     179 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
     180 .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
     181 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
     182 ;
     183RECBAR(DFN,HOURS) ;  Compiler Function: RECENT BARIUM STUDY
     184 ;
     185 Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT
     186 ; 
     187 ;
     188RECBARST(DFN,HOURS)    ;  Compiler Function: RECENT BARIUM ORDER STATUS
     189 ;
     190 Q:'$G(DFN) 0 Q:'$G(HOURS) 0
     191 N ORDER S ORDER=$P($$RECENTBA^ORKRA(DFN,HOURS),U) Q:'$L(ORDER) 0
     192 N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0
     193 Q 1_U_STATUS
     194 ;
     195TERMLKUP(OCXTERM,OCXLIST) ;
     196 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     197 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m

    r613 r623  
    1 OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK241  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK236+16^OCXOZ0A.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK241 Variables
    19         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    20         ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
    21         ; OCXDF(79) ---> Data Field: PATIENT TOO BIG FOR SCANNER TEXT (FREE TEXT)
    22         ; OCXDF(80) ---> Data Field: PATIENT TOO BIG FOR SCANNER DEVICE (FREE TEXT)
    23         ;
    24         ;      Local Extrinsic Functions
    25         ; CTMRI( -----------> CT MRI PHYSICAL LIMITS
    26         ; FILE(DFN,72, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS)
    27         ;
    28         S OCXDF(79)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",2),OCXDF(80)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",3),OCXOERR=$$FILE(DFN,72,"79,80") Q:OCXOERR
    29         Q
    30         ;
    31 CHK247  ; Look through the current environment for valid Event/Elements for this patient.
    32         ;  Called from CHK182+19^OCXOZ08.
    33         ;
    34         Q:$G(OCXOERR)
    35         ;
    36         ;    Local CHK247 Variables
    37         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    38         ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT)
    39         ;
    40         ;      Local Extrinsic Functions
    41         ; FILE(DFN,73, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CREATININE CLEARANCE ESTIMATE)
    42         ; FLAB( ------------> FORMATTED LAB RESULTS
    43         ;
    44         S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXOERR=$$FILE(DFN,73,"64,76") Q:OCXOERR
    45         Q
    46         ;
    47 CHK253  ; Look through the current environment for valid Event/Elements for this patient.
    48         ;  Called from CHK157+18^OCXOZ07.
    49         ;
    50         Q:$G(OCXOERR)
    51         ;
    52         ;    Local CHK253 Variables
    53         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    54         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    55         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    56         ;
    57         ;      Local Extrinsic Functions
    58         ; FILE(DFN,110, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: STAT CONSULT RESULT)
    59         ; FILE(DFN,75, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: STAT IMAGING RESULT)
    60         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    61         ;
    62         I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,75,"24,96") Q:OCXOERR
    63         I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,110,"24,96") Q:OCXOERR
    64         Q
    65         ;
    66 CHK264  ; Look through the current environment for valid Event/Elements for this patient.
    67         ;  Called from CHK151+18^OCXOZ07.
    68         ;
    69         Q:$G(OCXOERR)
    70         ;
    71         ;      Local Extrinsic Functions
    72         ; FILE(DFN,76, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: STAT LAB RESULT)
    73         ;
    74         S OCXOERR=$$FILE(DFN,76,"24,96") Q:OCXOERR
    75         Q
    76         ;
    77 CHK270  ; Look through the current environment for valid Event/Elements for this patient.
    78         ;  Called from CHK12+34^OCXOZ03.
    79         ;
    80         Q:$G(OCXOERR)
    81         ;
    82         ;    Local CHK270 Variables
    83         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    84         ; OCXDF(84) ---> Data Field: INPATIENT (BOOLEAN)
    85         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    86         ;
    87         ;      Local Extrinsic Functions
    88         ; FILE(DFN,84, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: INPATIENT FOOD-DRUG REACTION)
    89         ; PATLOC( ----------> PATIENT LOCATION
    90         ; WARDRMBD( --------> WARD ROOM-BED
    91         ;
    92         S OCXDF(84)=$P($$WARDRMBD(OCXDF(37)),"^",1) I $L(OCXDF(84)),(OCXDF(84)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,84,"82,147") Q:OCXOERR
    93         Q
    94         ;
    95 CHK280  ; Look through the current environment for valid Event/Elements for this patient.
    96         ;  Called from CHK188+15^OCXOZ09.
    97         ;
    98         Q:$G(OCXOERR)
    99         ;
    100         ;    Local CHK280 Variables
    101         ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
    102         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    103         ; OCXDF(125) --> Data Field: RECENT GLUCOPHAGE CREATININE TEXT (FREE TEXT)
    104         ; OCXDF(127) --> Data Field: RECENT GLUCOPHAGE CREATININE DAYS (NUMERIC)
    105         ;
    106         ;      Local Extrinsic Functions
    107         ;
    108         I ($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1) D CHK285
    109         Q
    110         ;
    111 CHK285  ; Look through the current environment for valid Event/Elements for this patient.
    112         ;  Called from CHK280+13.
    113         ;
    114         Q:$G(OCXOERR)
    115         ;
    116         ;      Local Extrinsic Functions
    117         ; FILE(DFN,86, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: GLUCOPHAGE ORDER)
    118         ;
    119         S OCXOERR=$$FILE(DFN,86,"125,127") Q:OCXOERR
    120         Q
    121         ;
    122 CHK293  ; Look through the current environment for valid Event/Elements for this patient.
    123         ;  Called from CHK113+20^OCXOZ06.
    124         ;
    125         Q:$G(OCXOERR)
    126         ;
    127         ;      Local Extrinsic Functions
    128         ; FILE(DFN,100, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER)
    129         ;
    130         S OCXOERR=$$FILE(DFN,100,"105") Q:OCXOERR
    131         Q
    132         ;
    133 CTMRI(DFN,OCXOI)        ;  Compiler Function: CT MRI PHYSICAL LIMITS
    134         ;
    135         N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL
    136         S OCXDEV=$$TYPE^ORKRA(OCXOI)
    137         Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U
    138         S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2)
    139         I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q")
    140         I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner"
    141         I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner"
    142         I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q")
    143         I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner"
    144         I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner"
    145         Q 0_U
    146         ;
    147 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    148         ;
    149         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    150         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    151         ;
    152         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    153         ;
    154         S OCXDATA(DFN,OCXELE)=1
    155         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    156         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    157         ;
    158         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    159         ;
    160         Q 0
    161         ;
    162 FLAB(DFN,OCXLIST,OCXSPEC)       ;  Compiler Function: FORMATTED LAB RESULTS
    163         ;
    164         Q:'$G(DFN) "<Patient Not Specified>"
    165         Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
    166         N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
    167         I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
    168         F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
    169         .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
    170         .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
    171         .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
    172         ..I $L($G(OCXSL)) D
    173         ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
    174         ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
    175         .....S OCXA($P(OCXX,U,7))=OCXX
    176         ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
    177         ..Q:'$L(OCXX)
    178         .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
    179         .I $L(OCXX) D
    180         ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
    181         ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
    182         ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
    183         .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
    184         Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
    185         ;
    186 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    187         Q:'$G(OIEN) ""
    188         ;
    189         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    190         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    191         Q $P(X,U,1)
    192         ;
    193 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    194         ;
    195         N OCXP1,OCXP2
    196         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    197         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    198         I OCXP2 D
    199         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    200         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    201         .E  S OCXP2=$P(OCXP2,"^",1)
    202         .S:'$L(OCXP2) OCXP2="NO LOC"
    203         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    204         ;
    205         S OCXP2=$G(^DPT(+$G(DFN),.1))
    206         I $L(OCXP2) Q "I^"_OCXP2
    207         Q "O^OUTPT"
    208         ;
    209 TERMLKUP(OCXTERM,OCXLIST)       ;
    210         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    211         ;
    212 WARDRMBD(DFN)   ;  Compiler Function: WARD ROOM-BED
    213         ;
    214         Q:'$G(DFN) 0
    215         N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0
    216         S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT
    217         ;
     1OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK241 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK236+16^OCXOZ0A.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK241 Variables
     19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     20 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC)
     21 ; OCXDF(79) ---> Data Field: PATIENT TOO BIG FOR SCANNER TEXT (FREE TEXT)
     22 ; OCXDF(80) ---> Data Field: PATIENT TOO BIG FOR SCANNER DEVICE (FREE TEXT)
     23 ;
     24 ;      Local Extrinsic Functions
     25 ; CTMRI( -----------> CT MRI PHYSICAL LIMITS
     26 ; FILE(DFN,72, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS)
     27 ;
     28 S OCXDF(79)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",2),OCXDF(80)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",3),OCXOERR=$$FILE(DFN,72,"79,80") Q:OCXOERR
     29 Q
     30 ;
     31CHK247 ; Look through the current environment for valid Event/Elements for this patient.
     32 ;  Called from CHK182+19^OCXOZ08.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 ;    Local CHK247 Variables
     37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     38 ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT)
     39 ;
     40 ;      Local Extrinsic Functions
     41 ; FILE(DFN,73, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CREATININE CLEARANCE ESTIMATE)
     42 ; FLAB( ------------> FORMATTED LAB RESULTS
     43 ;
     44 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXOERR=$$FILE(DFN,73,"64,76") Q:OCXOERR
     45 Q
     46 ;
     47CHK253 ; Look through the current environment for valid Event/Elements for this patient.
     48 ;  Called from CHK157+18^OCXOZ07.
     49 ;
     50 Q:$G(OCXOERR)
     51 ;
     52 ;    Local CHK253 Variables
     53 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     54 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     55 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     56 ;
     57 ;      Local Extrinsic Functions
     58 ; FILE(DFN,110, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: STAT CONSULT RESULT)
     59 ; FILE(DFN,75, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: STAT IMAGING RESULT)
     60 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     61 ;
     62 I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,75,"24,96") Q:OCXOERR
     63 I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,110,"24,96") Q:OCXOERR
     64 Q
     65 ;
     66CHK264 ; Look through the current environment for valid Event/Elements for this patient.
     67 ;  Called from CHK151+18^OCXOZ07.
     68 ;
     69 Q:$G(OCXOERR)
     70 ;
     71 ;      Local Extrinsic Functions
     72 ; FILE(DFN,76, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: STAT LAB RESULT)
     73 ;
     74 S OCXOERR=$$FILE(DFN,76,"24,96") Q:OCXOERR
     75 Q
     76 ;
     77CHK270 ; Look through the current environment for valid Event/Elements for this patient.
     78 ;  Called from CHK12+34^OCXOZ03.
     79 ;
     80 Q:$G(OCXOERR)
     81 ;
     82 ;    Local CHK270 Variables
     83 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     84 ; OCXDF(84) ---> Data Field: INPATIENT (BOOLEAN)
     85 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     86 ;
     87 ;      Local Extrinsic Functions
     88 ; FILE(DFN,84, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: INPATIENT FOOD-DRUG REACTION)
     89 ; PATLOC( ----------> PATIENT LOCATION
     90 ; WARDRMBD( --------> WARD ROOM-BED
     91 ;
     92 S OCXDF(84)=$P($$WARDRMBD(OCXDF(37)),"^",1) I $L(OCXDF(84)),(OCXDF(84)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,84,"82,147") Q:OCXOERR
     93 Q
     94 ;
     95CHK280 ; Look through the current environment for valid Event/Elements for this patient.
     96 ;  Called from CHK188+15^OCXOZ09.
     97 ;
     98 Q:$G(OCXOERR)
     99 ;
     100 ;    Local CHK280 Variables
     101 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT)
     102 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     103 ; OCXDF(125) --> Data Field: RECENT GLUCOPHAGE CREATININE TEXT (FREE TEXT)
     104 ; OCXDF(127) --> Data Field: RECENT GLUCOPHAGE CREATININE DAYS (NUMERIC)
     105 ;
     106 ;      Local Extrinsic Functions
     107 ;
     108 I ($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1) D CHK285
     109 Q
     110 ;
     111CHK285 ; Look through the current environment for valid Event/Elements for this patient.
     112 ;  Called from CHK280+13.
     113 ;
     114 Q:$G(OCXOERR)
     115 ;
     116 ;      Local Extrinsic Functions
     117 ; FILE(DFN,86, -----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: GLUCOPHAGE ORDER)
     118 ;
     119 S OCXOERR=$$FILE(DFN,86,"125,127") Q:OCXOERR
     120 Q
     121 ;
     122CHK293 ; Look through the current environment for valid Event/Elements for this patient.
     123 ;  Called from CHK113+20^OCXOZ06.
     124 ;
     125 Q:$G(OCXOERR)
     126 ;
     127 ;      Local Extrinsic Functions
     128 ; FILE(DFN,100, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER)
     129 ;
     130 S OCXOERR=$$FILE(DFN,100,"105") Q:OCXOERR
     131 Q
     132 ;
     133CTMRI(DFN,OCXOI) ;  Compiler Function: CT MRI PHYSICAL LIMITS
     134 ;
     135 N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL
     136 S OCXDEV=$$TYPE^ORKRA(OCXOI)
     137 Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U
     138 S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2)
     139 I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q")
     140 I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner"
     141 I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner"
     142 I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q")
     143 I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner"
     144 I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner"
     145 Q 0_U
     146 ;
     147FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     148 ;
     149 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     150 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     151 ;
     152 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     153 ;
     154 S OCXDATA(DFN,OCXELE)=1
     155 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     156 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     157 ;
     158 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     159 ;
     160 Q 0
     161 ;
     162FLAB(DFN,OCXLIST,OCXSPEC) ;  Compiler Function: FORMATTED LAB RESULTS
     163 ;
     164 Q:'$G(DFN) "<Patient Not Specified>"
     165 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
     166 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
     167 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
     168 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
     169 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
     170 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
     171 .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
     172 ..I $L($G(OCXSL)) D
     173 ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
     174 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
     175 .....S OCXA($P(OCXX,U,7))=OCXX
     176 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
     177 ..Q:'$L(OCXX)
     178 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
     179 .I $L(OCXX) D
     180 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
     181 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
     182 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
     183 .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
     184 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
     185 ;
     186ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     187 Q:'$G(OIEN) ""
     188 ;
     189 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     190 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     191 Q $P(X,U,1)
     192 ;
     193PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     194 ;
     195 N OCXP1,OCXP2
     196 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     197 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     198 I OCXP2 D
     199 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     200 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     201 .E  S OCXP2=$P(OCXP2,"^",1)
     202 .S:'$L(OCXP2) OCXP2="NO LOC"
     203 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     204 ;
     205 S OCXP2=$G(^DPT(+$G(DFN),.1))
     206 I $L(OCXP2) Q "I^"_OCXP2
     207 Q "O^OUTPT"
     208 ;
     209TERMLKUP(OCXTERM,OCXLIST) ;
     210 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     211 ;
     212WARDRMBD(DFN) ;  Compiler Function: WARD ROOM-BED
     213 ;
     214 Q:'$G(DFN) 0
     215 N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0
     216 S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT
     217 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m

    r613 r623  
    1 OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK302  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK6+19^OCXOZ02.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK302 Variables
    19         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    20         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    21         ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
    22         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    23         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    24         ;
    25         ;      Local Extrinsic Functions
    26         ; FILE(DFN,102, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SITE FLAGGED FINAL IMAGING RESULT)
    27         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    28         ; PATLOC( ----------> PATIENT LOCATION
    29         ;
    30         I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,102,"9,96,147") Q:OCXOERR
    31         Q
    32         ;
    33 CHK314  ; Look through the current environment for valid Event/Elements for this patient.
    34         ;  Called from CHK35+18^OCXOZ04.
    35         ;
    36         Q:$G(OCXOERR)
    37         ;
    38         ;    Local CHK314 Variables
    39         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    40         ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
    41         ;
    42         ;      Local Extrinsic Functions
    43         ; FILE(DFN,103, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB TEST RESULTS ABNORMAL)
    44         ;
    45         I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,103,"12,13,96,114") Q:OCXOERR
    46         Q
    47         ;
    48 CHK324  ; Look through the current environment for valid Event/Elements for this patient.
    49         ;  Called from CHK34+16^OCXOZ04.
    50         ;
    51         Q:$G(OCXOERR)
    52         ;
    53         ;    Local CHK324 Variables
    54         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    55         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    56         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    57         ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
    58         ;
    59         ;      Local Extrinsic Functions
    60         ; FILE(DFN,105, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB ORDER RESULTS CRITICAL)
    61         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    62         ;
    63         S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,105,"12,13,96,114") Q:OCXOERR
    64         Q
    65         ;
    66 CHK336  ; Look through the current environment for valid Event/Elements for this patient.
    67         ;  Called from CHK6+20^OCXOZ02.
    68         ;
    69         Q:$G(OCXOERR)
    70         ;
    71         ;    Local CHK336 Variables
    72         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    73         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    74         ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
    75         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    76         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    77         ;
    78         ;      Local Extrinsic Functions
    79         ; FILE(DFN,109, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SITE FLAGGED FINAL CONSULT RESULT)
    80         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    81         ; PATLOC( ----------> PATIENT LOCATION
    82         ;
    83         I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,109,"9,96,147") Q:OCXOERR
    84         Q
    85         ;
    86 CHK347  ; Look through the current environment for valid Event/Elements for this patient.
    87         ;  Called from CHK58+20^OCXOZ05.
    88         ;
    89         Q:$G(OCXOERR)
    90         ;
    91         ;    Local CHK347 Variables
    92         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    93         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    94         ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN)
    95         ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC)
    96         ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN)
    97         ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC)
    98         ;
    99         ;      Local Extrinsic Functions
    100         ;
    101         S OCXDF(137)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",2) I $L(OCXDF(137)) D CHK349
    102         S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),'(OCXDF(136)) D CHK371^OCXOZ0D
    103         S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),'(OCXDF(139)) D CHK375^OCXOZ0D
    104         S OCXDF(140)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",2) I $L(OCXDF(140)) D CHK378^OCXOZ0D
    105         Q
    106         ;
    107 CHK349  ; Look through the current environment for valid Event/Elements for this patient.
    108         ;  Called from CHK347+15.
    109         ;
    110         Q:$G(OCXOERR)
    111         ;
    112         ;    Local CHK349 Variables
    113         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    114         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    115         ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN)
    116         ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC)
    117         ;
    118         ;      Local Extrinsic Functions
    119         ;
    120         I (OCXDF(137)<1.5) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK353
    121         I (OCXDF(137)>1.499) D CHK355
    122         Q
    123         ;
    124 CHK353  ; Look through the current environment for valid Event/Elements for this patient.
    125         ;  Called from CHK349+13.
    126         ;
    127         Q:$G(OCXOERR)
    128         ;
    129         ;    Local CHK353 Variables
    130         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    131         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    132         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    133         ;
    134         ;      Local Extrinsic Functions
    135         ; FILE(DFN,114, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE ANC < 1.5)
    136         ;
    137         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,114,"130") Q:OCXOERR
    138         Q
    139         ;
    140 CHK355  ; Look through the current environment for valid Event/Elements for this patient.
    141         ;  Called from CHK349+14.
    142         ;
    143         Q:$G(OCXOERR)
    144         ;
    145         ;    Local CHK355 Variables
    146         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    147         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    148         ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN)
    149         ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC)
    150         ;
    151         ;      Local Extrinsic Functions
    152         ;
    153         S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK358
    154         I (OCXDF(137)<"2.0") S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK505^OCXOZ0G
    155         Q
    156         ;
    157 CHK358  ; Look through the current environment for valid Event/Elements for this patient.
    158         ;  Called from CHK355+13.
    159         ;
    160         Q:$G(OCXOERR)
    161         ;
    162         ;    Local CHK358 Variables
    163         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    164         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    165         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    166         ;
    167         ;      Local Extrinsic Functions
    168         ; FILE(DFN,115, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE ANC >= 1.5)
    169         ;
    170         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,115,"130") Q:OCXOERR
    171         Q
    172         ;
    173 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    174         ;
    175         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    176         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    177         ;
    178         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    179         ;
    180         S OCXDATA(DFN,OCXELE)=1
    181         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    182         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    183         ;
    184         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    185         ;
    186         Q 0
    187         ;
    188 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    189         Q:'$G(OIEN) ""
    190         ;
    191         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    192         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    193         Q $P(X,U,1)
    194         ;
    195 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    196         ;
    197         N OCXP1,OCXP2
    198         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    199         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    200         I OCXP2 D
    201         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    202         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    203         .E  S OCXP2=$P(OCXP2,"^",1)
    204         .S:'$L(OCXP2) OCXP2="NO LOC"
    205         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    206         ;
    207         S OCXP2=$G(^DPT(+$G(DFN),.1))
    208         I $L(OCXP2) Q "I^"_OCXP2
    209         Q "O^OUTPT"
    210         ;
     1OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK302 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK6+19^OCXOZ02.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK302 Variables
     19 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     20 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     21 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
     22 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     23 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     24 ;
     25 ;      Local Extrinsic Functions
     26 ; FILE(DFN,102, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SITE FLAGGED FINAL IMAGING RESULT)
     27 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     28 ; PATLOC( ----------> PATIENT LOCATION
     29 ;
     30 I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,102,"9,96,147") Q:OCXOERR
     31 Q
     32 ;
     33CHK314 ; Look through the current environment for valid Event/Elements for this patient.
     34 ;  Called from CHK35+18^OCXOZ04.
     35 ;
     36 Q:$G(OCXOERR)
     37 ;
     38 ;    Local CHK314 Variables
     39 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     40 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
     41 ;
     42 ;      Local Extrinsic Functions
     43 ; FILE(DFN,103, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB TEST RESULTS ABNORMAL)
     44 ;
     45 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,103,"12,13,96,114") Q:OCXOERR
     46 Q
     47 ;
     48CHK324 ; Look through the current environment for valid Event/Elements for this patient.
     49 ;  Called from CHK34+16^OCXOZ04.
     50 ;
     51 Q:$G(OCXOERR)
     52 ;
     53 ;    Local CHK324 Variables
     54 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     55 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     56 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     57 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT)
     58 ;
     59 ;      Local Extrinsic Functions
     60 ; FILE(DFN,105, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: HL7 LAB ORDER RESULTS CRITICAL)
     61 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     62 ;
     63 S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,105,"12,13,96,114") Q:OCXOERR
     64 Q
     65 ;
     66CHK336 ; Look through the current environment for valid Event/Elements for this patient.
     67 ;  Called from CHK6+20^OCXOZ02.
     68 ;
     69 Q:$G(OCXOERR)
     70 ;
     71 ;    Local CHK336 Variables
     72 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     73 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     74 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN)
     75 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     76 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     77 ;
     78 ;      Local Extrinsic Functions
     79 ; FILE(DFN,109, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: SITE FLAGGED FINAL CONSULT RESULT)
     80 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     81 ; PATLOC( ----------> PATIENT LOCATION
     82 ;
     83 I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,109,"9,96,147") Q:OCXOERR
     84 Q
     85 ;
     86CHK347 ; Look through the current environment for valid Event/Elements for this patient.
     87 ;  Called from CHK58+20^OCXOZ05.
     88 ;
     89 Q:$G(OCXOERR)
     90 ;
     91 ;    Local CHK347 Variables
     92 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     93 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     94 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN)
     95 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC)
     96 ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN)
     97 ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC)
     98 ;
     99 ;      Local Extrinsic Functions
     100 ;
     101 S OCXDF(137)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",2) I $L(OCXDF(137)) D CHK349
     102 S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),'(OCXDF(136)) D CHK374^OCXOZ0D
     103 S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),'(OCXDF(139)) D CHK379^OCXOZ0D
     104 S OCXDF(140)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",2) I $L(OCXDF(140)) D CHK383^OCXOZ0D
     105 Q
     106 ;
     107CHK349 ; Look through the current environment for valid Event/Elements for this patient.
     108 ;  Called from CHK347+15.
     109 ;
     110 Q:$G(OCXOERR)
     111 ;
     112 ;    Local CHK349 Variables
     113 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     114 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     115 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN)
     116 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC)
     117 ;
     118 ;      Local Extrinsic Functions
     119 ;
     120 I (OCXDF(137)<1.5) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK353
     121 I (OCXDF(137)>1.499) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK359^OCXOZ0D
     122 Q
     123 ;
     124CHK353 ; Look through the current environment for valid Event/Elements for this patient.
     125 ;  Called from CHK349+13.
     126 ;
     127 Q:$G(OCXOERR)
     128 ;
     129 ;    Local CHK353 Variables
     130 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     131 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     132 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     133 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     134 ;
     135 ;      Local Extrinsic Functions
     136 ; FILE(DFN,114, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE ANC < 1.5)
     137 ; MSGTEXT( ---------> MESSAGE TEXT
     138 ;
     139 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,114,"130,145") Q:OCXOERR
     140 Q
     141 ;
     142FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     143 ;
     144 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     145 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     146 ;
     147 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     148 ;
     149 S OCXDATA(DFN,OCXELE)=1
     150 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     151 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     152 ;
     153 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     154 ;
     155 Q 0
     156 ;
     157MSGTEXT(ID)    ;  Compiler Function: MESSAGE TEXT
     158 ;
     159 N MSG
     160 S MSG=""
     161 ;
     162 I ID="AMITRIPTYLINE" D
     163 .S MSG="Amitriptyline can cause cognitive impairment and loss of"
     164 .S MSG=MSG_" balance in older patients. Consider other antidepressant"
     165 .S MSG=MSG_" medications on formulary."
     166 ;
     167 I ID="CHLORPROPAMIDE" D
     168 .S MSG="Older patients may experience hypoglycemia with"
     169 .S MSG=MSG_" Chlorpropamide due to its long duration and variable"
     170 .S MSG=MSG_" renal secretion. They may also be at increased risk for"
     171 .S MSG=MSG_" Chlorpropamide-induced SIADH."
     172 ;
     173 I ID="DIPYRIDAMOLE" D
     174 .S MSG="Older patients can experience adverse reactions at high doses"
     175 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI"
     176 .S MSG=MSG_" intolerance.) There is also questionable efficacy at"
     177 .S MSG=MSG_" lower doses."
     178 ;
     179 I ID="CLOZWBC30_35" D
     180 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill"
     181 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC"
     182 .S MSG=MSG_" immediately."
     183 ;
     184 Q MSG
     185 ;
     186ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     187 Q:'$G(OIEN) ""
     188 ;
     189 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     190 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     191 Q $P(X,U,1)
     192 ;
     193PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     194 ;
     195 N OCXP1,OCXP2
     196 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     197 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     198 I OCXP2 D
     199 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     200 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     201 .E  S OCXP2=$P(OCXP2,"^",1)
     202 .S:'$L(OCXP2) OCXP2="NO LOC"
     203 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     204 ;
     205 S OCXP2=$G(^DPT(+$G(DFN),.1))
     206 I $L(OCXP2) Q "I^"_OCXP2
     207 Q "O^OUTPT"
     208 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m

    r613 r623  
    1 OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK360  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK198+9^OCXOZ09.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK360 Variables
    19         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    20         ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT)
    21         ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT)
    22         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    23         ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN)
    24         ;
    25         ;      Local Extrinsic Functions
    26         ;
    27         S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(132)=$P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",1) D CHK365
    28         S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)) D CHK497^OCXOZ0G
    29         Q
    30         ;
    31 CHK365  ; Look through the current environment for valid Event/Elements for this patient.
    32         ;  Called from CHK360+14.
    33         ;
    34         Q:$G(OCXOERR)
    35         ;
    36         ;    Local CHK365 Variables
    37         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    38         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    39         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    40         ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN)
    41         ;
    42         ;      Local Extrinsic Functions
    43         ; FILE(DFN,116, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE DRUG SELECTED)
    44         ;
    45         I $L(OCXDF(132)),(OCXDF(132)) S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,116,"130") Q:OCXOERR
    46         Q
    47         ;
    48 CHK371  ; Look through the current environment for valid Event/Elements for this patient.
    49         ;  Called from CHK347+16^OCXOZ0C.
    50         ;
    51         Q:$G(OCXOERR)
    52         ;
    53         ;    Local CHK371 Variables
    54         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    55         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    56         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    57         ;
    58         ;      Local Extrinsic Functions
    59         ; FILE(DFN,117, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS)
    60         ;
    61         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,117,"130") Q:OCXOERR
    62         Q
    63         ;
    64 CHK375  ; Look through the current environment for valid Event/Elements for this patient.
    65         ;  Called from CHK347+17^OCXOZ0C.
    66         ;
    67         Q:$G(OCXOERR)
    68         ;
    69         ;    Local CHK375 Variables
    70         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    71         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    72         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    73         ;
    74         ;      Local Extrinsic Functions
    75         ; FILE(DFN,118, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS)
    76         ;
    77         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,118,"130") Q:OCXOERR
    78         Q
    79         ;
    80 CHK378  ; Look through the current environment for valid Event/Elements for this patient.
    81         ;  Called from CHK347+18^OCXOZ0C.
    82         ;
    83         Q:$G(OCXOERR)
    84         ;
    85         ;    Local CHK378 Variables
    86         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    87         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    88         ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN)
    89         ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC)
    90         ;
    91         ;      Local Extrinsic Functions
    92         ;
    93         I (OCXDF(140)<"3.0") S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK382
    94         I (OCXDF(140)>2.999),(OCXDF(140)<3.5) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK388
    95         I (OCXDF(140)>3.499) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK393
    96         Q
    97         ;
    98 CHK382  ; Look through the current environment for valid Event/Elements for this patient.
    99         ;  Called from CHK378+13.
    100         ;
    101         Q:$G(OCXOERR)
    102         ;
    103         ;    Local CHK382 Variables
    104         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    105         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    106         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    107         ;
    108         ;      Local Extrinsic Functions
    109         ; FILE(DFN,119, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE WBC < 3.0)
    110         ;
    111         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,119,"130") Q:OCXOERR
    112         Q
    113         ;
    114 CHK388  ; Look through the current environment for valid Event/Elements for this patient.
    115         ;  Called from CHK378+14.
    116         ;
    117         Q:$G(OCXOERR)
    118         ;
    119         ;    Local CHK388 Variables
    120         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    121         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    122         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    123         ;
    124         ;      Local Extrinsic Functions
    125         ; FILE(DFN,120, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5)
    126         ;
    127         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,120,"130") Q:OCXOERR
    128         Q
    129         ;
    130 CHK393  ; Look through the current environment for valid Event/Elements for this patient.
    131         ;  Called from CHK378+15.
    132         ;
    133         Q:$G(OCXOERR)
    134         ;
    135         ;    Local CHK393 Variables
    136         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    137         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    138         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    139         ;
    140         ;      Local Extrinsic Functions
    141         ; FILE(DFN,121, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE WBC >= 3.5)
    142         ;
    143         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,121,"130") Q:OCXOERR
    144         Q
    145         ;
    146 CHK398  ; Look through the current environment for valid Event/Elements for this patient.
    147         ;  Called from CHK58+21^OCXOZ05.
    148         ;
    149         Q:$G(OCXOERR)
    150         ;
    151         ;    Local CHK398 Variables
    152         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    153         ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
    154         ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT)
    155         ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT)
    156         ;
    157         ;      Local Extrinsic Functions
    158         ; MSGTEXT( ---------> MESSAGE TEXT
    159         ;
    160         I (OCXDF(143)["AMITRIPTYLINE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK403^OCXOZ0E
    161         I (OCXDF(143)["CHLORPROPAMIDE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK410^OCXOZ0E
    162         I (OCXDF(143)["DIPYRIDAMOLE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK417^OCXOZ0E
    163         Q
    164         ;
    165 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    166         ;
    167         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    168         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    169         ;
    170         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    171         ;
    172         S OCXDATA(DFN,OCXELE)=1
    173         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    174         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    175         ;
    176         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    177         ;
    178         Q 0
    179         ;
    180 MSGTEXT(ID)        ;  Compiler Function: MESSAGE TEXT
    181         ;
    182         N MSG
    183         S MSG=""
    184         ;
    185         I ID="AMITRIPTYLINE" D
    186         .S MSG="Amitriptyline can cause cognitive impairment and loss of"
    187         .S MSG=MSG_" balance in older patients. Consider other antidepressant"
    188         .S MSG=MSG_" medications on formulary."
    189         ;
    190         I ID="CHLORPROPAMIDE" D
    191         .S MSG="Older patients may experience hypoglycemia with"
    192         .S MSG=MSG_" Chlorpropamide due to its long duration and variable"
    193         .S MSG=MSG_" renal secretion. They may also be at increased risk for"
    194         .S MSG=MSG_" Chlorpropamide-induced SIADH."
    195         ;
    196         I ID="DIPYRIDAMOLE" D
    197         .S MSG="Older patients can experience adverse reactions at high doses"
    198         .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI"
    199         .S MSG=MSG_" intolerance.) There is also questionable efficacy at"
    200         .S MSG=MSG_" lower doses."
    201         ;
    202         I ID="CLOZWBC30_35" D
    203         .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill"
    204         .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC"
    205         .S MSG=MSG_" immediately."
    206         ;
    207         Q MSG
    208         ;
     1OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK359 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK349+14^OCXOZ0C.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK359 Variables
     19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     20 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     21 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     22 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     23 ;
     24 ;      Local Extrinsic Functions
     25 ; FILE(DFN,115, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE ANC >= 1.5)
     26 ; MSGTEXT( ---------> MESSAGE TEXT
     27 ;
     28 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,115,"130,145") Q:OCXOERR
     29 Q
     30 ;
     31CHK362 ; Look through the current environment for valid Event/Elements for this patient.
     32 ;  Called from CHK198+9^OCXOZ09.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 ;    Local CHK362 Variables
     37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     38 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT)
     39 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT)
     40 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     41 ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN)
     42 ;
     43 ;      Local Extrinsic Functions
     44 ;
     45 S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(132)=$P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",1) D CHK367
     46 S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)) D CHK505^OCXOZ0G
     47 Q
     48 ;
     49CHK367 ; Look through the current environment for valid Event/Elements for this patient.
     50 ;  Called from CHK362+14.
     51 ;
     52 Q:$G(OCXOERR)
     53 ;
     54 ;    Local CHK367 Variables
     55 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     56 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     57 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     58 ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN)
     59 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     60 ;
     61 ;      Local Extrinsic Functions
     62 ; FILE(DFN,116, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE DRUG SELECTED)
     63 ; MSGTEXT( ---------> MESSAGE TEXT
     64 ;
     65 I $L(OCXDF(132)),(OCXDF(132)) S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,116,"130,145") Q:OCXOERR
     66 Q
     67 ;
     68CHK374 ; Look through the current environment for valid Event/Elements for this patient.
     69 ;  Called from CHK347+16^OCXOZ0C.
     70 ;
     71 Q:$G(OCXOERR)
     72 ;
     73 ;    Local CHK374 Variables
     74 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     75 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     76 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     77 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     78 ;
     79 ;      Local Extrinsic Functions
     80 ; FILE(DFN,117, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS)
     81 ; MSGTEXT( ---------> MESSAGE TEXT
     82 ;
     83 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,117,"130,145") Q:OCXOERR
     84 Q
     85 ;
     86CHK379 ; Look through the current environment for valid Event/Elements for this patient.
     87 ;  Called from CHK347+17^OCXOZ0C.
     88 ;
     89 Q:$G(OCXOERR)
     90 ;
     91 ;    Local CHK379 Variables
     92 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     93 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     94 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     95 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     96 ;
     97 ;      Local Extrinsic Functions
     98 ; FILE(DFN,118, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS)
     99 ; MSGTEXT( ---------> MESSAGE TEXT
     100 ;
     101 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,118,"130,145") Q:OCXOERR
     102 Q
     103 ;
     104CHK383 ; Look through the current environment for valid Event/Elements for this patient.
     105 ;  Called from CHK347+18^OCXOZ0C.
     106 ;
     107 Q:$G(OCXOERR)
     108 ;
     109 ;    Local CHK383 Variables
     110 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     111 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     112 ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN)
     113 ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC)
     114 ;
     115 ;      Local Extrinsic Functions
     116 ;
     117 I (OCXDF(140)<"3.0") S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK387
     118 I (OCXDF(140)>2.999),(OCXDF(140)<3.5) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK394
     119 I (OCXDF(140)>3.499) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK400^OCXOZ0E
     120 Q
     121 ;
     122CHK387 ; Look through the current environment for valid Event/Elements for this patient.
     123 ;  Called from CHK383+13.
     124 ;
     125 Q:$G(OCXOERR)
     126 ;
     127 ;    Local CHK387 Variables
     128 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     129 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     130 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     131 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     132 ;
     133 ;      Local Extrinsic Functions
     134 ; FILE(DFN,119, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE WBC < 3.0)
     135 ; MSGTEXT( ---------> MESSAGE TEXT
     136 ;
     137 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,119,"130,145") Q:OCXOERR
     138 Q
     139 ;
     140CHK394 ; Look through the current environment for valid Event/Elements for this patient.
     141 ;  Called from CHK383+14.
     142 ;
     143 Q:$G(OCXOERR)
     144 ;
     145 ;    Local CHK394 Variables
     146 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     147 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     148 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     149 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     150 ;
     151 ;      Local Extrinsic Functions
     152 ; FILE(DFN,120, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5)
     153 ; MSGTEXT( ---------> MESSAGE TEXT
     154 ;
     155 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,120,"130,145") Q:OCXOERR
     156 Q
     157 ;
     158FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     159 ;
     160 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     161 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     162 ;
     163 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     164 ;
     165 S OCXDATA(DFN,OCXELE)=1
     166 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     167 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     168 ;
     169 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     170 ;
     171 Q 0
     172 ;
     173MSGTEXT(ID)    ;  Compiler Function: MESSAGE TEXT
     174 ;
     175 N MSG
     176 S MSG=""
     177 ;
     178 I ID="AMITRIPTYLINE" D
     179 .S MSG="Amitriptyline can cause cognitive impairment and loss of"
     180 .S MSG=MSG_" balance in older patients. Consider other antidepressant"
     181 .S MSG=MSG_" medications on formulary."
     182 ;
     183 I ID="CHLORPROPAMIDE" D
     184 .S MSG="Older patients may experience hypoglycemia with"
     185 .S MSG=MSG_" Chlorpropamide due to its long duration and variable"
     186 .S MSG=MSG_" renal secretion. They may also be at increased risk for"
     187 .S MSG=MSG_" Chlorpropamide-induced SIADH."
     188 ;
     189 I ID="DIPYRIDAMOLE" D
     190 .S MSG="Older patients can experience adverse reactions at high doses"
     191 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI"
     192 .S MSG=MSG_" intolerance.) There is also questionable efficacy at"
     193 .S MSG=MSG_" lower doses."
     194 ;
     195 I ID="CLOZWBC30_35" D
     196 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill"
     197 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC"
     198 .S MSG=MSG_" immediately."
     199 ;
     200 Q MSG
     201 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m

    r613 r623  
    1 OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK403  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK398+14^OCXOZ0D.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK403 Variables
    19         ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
    20         ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
    21         ;
    22         ;      Local Extrinsic Functions
    23         ; FILE(DFN,122, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: AMITRIPTYLINE ORDER)
    24         ; MSGTEXT( ---------> MESSAGE TEXT
    25         ;
    26         S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,122,"62,141,142,144") Q:OCXOERR
    27         Q
    28         ;
    29 CHK410  ; Look through the current environment for valid Event/Elements for this patient.
    30         ;  Called from CHK398+15^OCXOZ0D.
    31         ;
    32         Q:$G(OCXOERR)
    33         ;
    34         ;    Local CHK410 Variables
    35         ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
    36         ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
    37         ;
    38         ;      Local Extrinsic Functions
    39         ; FILE(DFN,123, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CHLORPROPAMIDE ORDER)
    40         ; MSGTEXT( ---------> MESSAGE TEXT
    41         ;
    42         S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,123,"62,141,142,144") Q:OCXOERR
    43         Q
    44         ;
    45 CHK417  ; Look through the current environment for valid Event/Elements for this patient.
    46         ;  Called from CHK398+16^OCXOZ0D.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ;    Local CHK417 Variables
    51         ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
    52         ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
    53         ;
    54         ;      Local Extrinsic Functions
    55         ; FILE(DFN,124, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: DIPYRIDAMOLE ORDER)
    56         ; MSGTEXT( ---------> MESSAGE TEXT
    57         ;
    58         S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,124,"62,141,142,144") Q:OCXOERR
    59         Q
    60         ;
    61 CHK426  ; Look through the current environment for valid Event/Elements for this patient.
    62         ;  Called from CHK164+16^OCXOZ08.
    63         ;
    64         Q:$G(OCXOERR)
    65         ;
    66         ;    Local CHK426 Variables
    67         ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
    68         ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT)
    69         ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
    70         ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
    71         ;
    72         ;      Local Extrinsic Functions
    73         ; MSGTEXT( ---------> MESSAGE TEXT
    74         ;
    75         I (OCXDF(62)>64) S OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE"),OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE") D CHK430
    76         Q
    77         ;
    78 CHK430  ; Look through the current environment for valid Event/Elements for this patient.
    79         ;  Called from CHK426+14.
    80         ;
    81         Q:$G(OCXOERR)
    82         ;
    83         ;      Local Extrinsic Functions
    84         ; FILE(DFN,125, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: MED ORDER FOR PT > 64)
    85         ;
    86         S OCXOERR=$$FILE(DFN,125,"62,141,142,144") Q:OCXOERR
    87         Q
    88         ;
    89 CHK436  ; Look through the current environment for valid Event/Elements for this patient.
    90         ;  Called from CHK1+33^OCXOZ02.
    91         ;
    92         Q:$G(OCXOERR)
    93         ;
    94         ;    Local CHK436 Variables
    95         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    96         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    97         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    98         ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
    99         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    100         ;
    101         ;      Local Extrinsic Functions
    102         ; FILE(DFN,127, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: INPATIENT)
    103         ; FILE(DFN,128, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: OUTPATIENT)
    104         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    105         ; PATLOC( ----------> PATIENT LOCATION
    106         ;
    107         I (OCXDF(146)="I"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,127,"9,96,147") Q:OCXOERR
    108         I (OCXDF(146)="O"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,128,"9,96,147") Q:OCXOERR
    109         Q
    110         ;
    111 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    112         ;
    113         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    114         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    115         ;
    116         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    117         ;
    118         S OCXDATA(DFN,OCXELE)=1
    119         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    120         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    121         ;
    122         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    123         ;
    124         Q 0
    125         ;
    126 MSGTEXT(ID)        ;  Compiler Function: MESSAGE TEXT
    127         ;
    128         N MSG
    129         S MSG=""
    130         ;
    131         I ID="AMITRIPTYLINE" D
    132         .S MSG="Amitriptyline can cause cognitive impairment and loss of"
    133         .S MSG=MSG_" balance in older patients. Consider other antidepressant"
    134         .S MSG=MSG_" medications on formulary."
    135         ;
    136         I ID="CHLORPROPAMIDE" D
    137         .S MSG="Older patients may experience hypoglycemia with"
    138         .S MSG=MSG_" Chlorpropamide due to its long duration and variable"
    139         .S MSG=MSG_" renal secretion. They may also be at increased risk for"
    140         .S MSG=MSG_" Chlorpropamide-induced SIADH."
    141         ;
    142         I ID="DIPYRIDAMOLE" D
    143         .S MSG="Older patients can experience adverse reactions at high doses"
    144         .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI"
    145         .S MSG=MSG_" intolerance.) There is also questionable efficacy at"
    146         .S MSG=MSG_" lower doses."
    147         ;
    148         I ID="CLOZWBC30_35" D
    149         .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill"
    150         .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC"
    151         .S MSG=MSG_" immediately."
    152         ;
    153         Q MSG
    154         ;
    155 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    156         Q:'$G(OIEN) ""
    157         ;
    158         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    159         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    160         Q $P(X,U,1)
    161         ;
    162 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    163         ;
    164         N OCXP1,OCXP2
    165         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    166         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    167         I OCXP2 D
    168         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    169         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    170         .E  S OCXP2=$P(OCXP2,"^",1)
    171         .S:'$L(OCXP2) OCXP2="NO LOC"
    172         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    173         ;
    174         S OCXP2=$G(^DPT(+$G(DFN),.1))
    175         I $L(OCXP2) Q "I^"_OCXP2
    176         Q "O^OUTPT"
    177         ;
     1OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK400 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK383+15^OCXOZ0D.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK400 Variables
     19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     20 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
     21 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
     22 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT)
     23 ;
     24 ;      Local Extrinsic Functions
     25 ; FILE(DFN,121, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE WBC >= 3.5)
     26 ; MSGTEXT( ---------> MESSAGE TEXT
     27 ;
     28 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,121,"130,145") Q:OCXOERR
     29 Q
     30 ;
     31CHK406 ; Look through the current environment for valid Event/Elements for this patient.
     32 ;  Called from CHK58+21^OCXOZ05.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 ;    Local CHK406 Variables
     37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     38 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
     39 ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT)
     40 ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT)
     41 ;
     42 ;      Local Extrinsic Functions
     43 ; MSGTEXT( ---------> MESSAGE TEXT
     44 ;
     45 I (OCXDF(143)["AMITRIPTYLINE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK411
     46 I (OCXDF(143)["CHLORPROPAMIDE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK418
     47 I (OCXDF(143)["DIPYRIDAMOLE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK425
     48 Q
     49 ;
     50CHK411 ; Look through the current environment for valid Event/Elements for this patient.
     51 ;  Called from CHK406+14.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;    Local CHK411 Variables
     56 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
     57 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
     58 ;
     59 ;      Local Extrinsic Functions
     60 ; FILE(DFN,122, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: AMITRIPTYLINE ORDER)
     61 ; MSGTEXT( ---------> MESSAGE TEXT
     62 ;
     63 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,122,"62,141,142,144") Q:OCXOERR
     64 Q
     65 ;
     66CHK418 ; Look through the current environment for valid Event/Elements for this patient.
     67 ;  Called from CHK406+15.
     68 ;
     69 Q:$G(OCXOERR)
     70 ;
     71 ;    Local CHK418 Variables
     72 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
     73 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
     74 ;
     75 ;      Local Extrinsic Functions
     76 ; FILE(DFN,123, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CHLORPROPAMIDE ORDER)
     77 ; MSGTEXT( ---------> MESSAGE TEXT
     78 ;
     79 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,123,"62,141,142,144") Q:OCXOERR
     80 Q
     81 ;
     82CHK425 ; Look through the current environment for valid Event/Elements for this patient.
     83 ;  Called from CHK406+16.
     84 ;
     85 Q:$G(OCXOERR)
     86 ;
     87 ;    Local CHK425 Variables
     88 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
     89 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
     90 ;
     91 ;      Local Extrinsic Functions
     92 ; FILE(DFN,124, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: DIPYRIDAMOLE ORDER)
     93 ; MSGTEXT( ---------> MESSAGE TEXT
     94 ;
     95 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,124,"62,141,142,144") Q:OCXOERR
     96 Q
     97 ;
     98CHK434 ; Look through the current environment for valid Event/Elements for this patient.
     99 ;  Called from CHK164+16^OCXOZ08.
     100 ;
     101 Q:$G(OCXOERR)
     102 ;
     103 ;    Local CHK434 Variables
     104 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC)
     105 ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT)
     106 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT)
     107 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT)
     108 ;
     109 ;      Local Extrinsic Functions
     110 ; MSGTEXT( ---------> MESSAGE TEXT
     111 ;
     112 I (OCXDF(62)>64) S OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE"),OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE") D CHK438
     113 Q
     114 ;
     115CHK438 ; Look through the current environment for valid Event/Elements for this patient.
     116 ;  Called from CHK434+14.
     117 ;
     118 Q:$G(OCXOERR)
     119 ;
     120 ;      Local Extrinsic Functions
     121 ; FILE(DFN,125, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: MED ORDER FOR PT > 64)
     122 ;
     123 S OCXOERR=$$FILE(DFN,125,"62,141,142,144") Q:OCXOERR
     124 Q
     125 ;
     126CHK444 ; Look through the current environment for valid Event/Elements for this patient.
     127 ;  Called from CHK1+33^OCXOZ02.
     128 ;
     129 Q:$G(OCXOERR)
     130 ;
     131 ;    Local CHK444 Variables
     132 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     133 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     134 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     135 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT)
     136 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     137 ;
     138 ;      Local Extrinsic Functions
     139 ; FILE(DFN,127, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: INPATIENT)
     140 ; FILE(DFN,128, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: OUTPATIENT)
     141 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     142 ; PATLOC( ----------> PATIENT LOCATION
     143 ;
     144 I (OCXDF(146)="I"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,127,"9,96,147") Q:OCXOERR
     145 I (OCXDF(146)="O"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,128,"9,96,147") Q:OCXOERR
     146 Q
     147 ;
     148FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     149 ;
     150 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     151 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     152 ;
     153 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     154 ;
     155 S OCXDATA(DFN,OCXELE)=1
     156 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     157 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     158 ;
     159 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     160 ;
     161 Q 0
     162 ;
     163MSGTEXT(ID)    ;  Compiler Function: MESSAGE TEXT
     164 ;
     165 N MSG
     166 S MSG=""
     167 ;
     168 I ID="AMITRIPTYLINE" D
     169 .S MSG="Amitriptyline can cause cognitive impairment and loss of"
     170 .S MSG=MSG_" balance in older patients. Consider other antidepressant"
     171 .S MSG=MSG_" medications on formulary."
     172 ;
     173 I ID="CHLORPROPAMIDE" D
     174 .S MSG="Older patients may experience hypoglycemia with"
     175 .S MSG=MSG_" Chlorpropamide due to its long duration and variable"
     176 .S MSG=MSG_" renal secretion. They may also be at increased risk for"
     177 .S MSG=MSG_" Chlorpropamide-induced SIADH."
     178 ;
     179 I ID="DIPYRIDAMOLE" D
     180 .S MSG="Older patients can experience adverse reactions at high doses"
     181 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI"
     182 .S MSG=MSG_" intolerance.) There is also questionable efficacy at"
     183 .S MSG=MSG_" lower doses."
     184 ;
     185 I ID="CLOZWBC30_35" D
     186 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill"
     187 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC"
     188 .S MSG=MSG_" immediately."
     189 ;
     190 Q MSG
     191 ;
     192ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     193 Q:'$G(OIEN) ""
     194 ;
     195 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     196 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     197 Q $P(X,U,1)
     198 ;
     199PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     200 ;
     201 N OCXP1,OCXP2
     202 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     203 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     204 I OCXP2 D
     205 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     206 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     207 .E  S OCXP2=$P(OCXP2,"^",1)
     208 .S:'$L(OCXP2) OCXP2="NO LOC"
     209 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     210 ;
     211 S OCXP2=$G(^DPT(+$G(DFN),.1))
     212 I $L(OCXP2) Q "I^"_OCXP2
     213 Q "O^OUTPT"
     214 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m

    r613 r623  
    1 OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK446  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK58+22^OCXOZ05.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK446 Variables
    19         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    20         ; OCXDF(57) ---> Data Field: MOST RECENT RENAL TEST ABNORMAL FLAG (BOOLEAN)
    21         ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT)
    22         ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC)
    23         ; OCXDF(155) --> Data Field: RECENT CONTRAST MEDIA CREATININE FLAG (BOOLEAN)
    24         ;
    25         ;      Local Extrinsic Functions
    26         ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
    27         ; RECCREAT( --------> RECENT CREATININE LAB PROCEDURE
    28         ;
    29         S OCXDF(57)=$P($$ABREN(OCXDF(37)),"^",1) I $L(OCXDF(57)),(OCXDF(57)) S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) D CHK451
    30         S OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) I $L(OCXDF(154)) S OCXDF(155)=$P($$RECCREAT(OCXDF(37),OCXDF(154)),"^",1) I $L(OCXDF(155)),'(OCXDF(155)) D CHK482^OCXOZ0G
    31         Q
    32         ;
    33 CHK451  ; Look through the current environment for valid Event/Elements for this patient.
    34         ;  Called from CHK446+16.
    35         ;
    36         Q:$G(OCXOERR)
    37         ;
    38         ;      Local Extrinsic Functions
    39         ; FILE(DFN,129, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ABNORMAL RENAL RESULTS)
    40         ;
    41         S OCXOERR=$$FILE(DFN,129,"58,154") Q:OCXOERR
    42         Q
    43         ;
    44 CHK458  ; Look through the current environment for valid Event/Elements for this patient.
    45         ;  Called from CHK196+18^OCXOZ09.
    46         ;
    47         Q:$G(OCXOERR)
    48         ;
    49         ;    Local CHK458 Variables
    50         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    51         ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT)
    52         ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC)
    53         ;
    54         ;      Local Extrinsic Functions
    55         ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
    56         ; FILE(DFN,130, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CONTRAST MEDIA ORDER)
    57         ;
    58         S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,130,"58,154") Q:OCXOERR
    59         Q
    60         ;
    61 CHK463  ; Look through the current environment for valid Event/Elements for this patient.
    62         ;  Called from CHK1+34^OCXOZ02.
    63         ;
    64         Q:$G(OCXOERR)
    65         ;
    66         ;    Local CHK463 Variables
    67         ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT)
    68         ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
    69         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    70         ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
    71         ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
    72         ; OCXDF(150) --> Data Field: LAB RESULT < THRESHOLD (BOOLEAN)
    73         ; OCXDF(151) --> Data Field: LAB RESULT > THRESHOLD (BOOLEAN)
    74         ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC)
    75         ;
    76         ;      Local Extrinsic Functions
    77         ; LABTHRSB( --------> LAB THRESHOLD EXCEEDED BOOLEAN
    78         ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
    79         ;
    80         S OCXDF(151)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),">"),"^",1) I $L(OCXDF(151)),(OCXDF(151)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK469
    81         S OCXDF(150)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),"<"),"^",1) I $L(OCXDF(150)),(OCXDF(150)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK476
    82         Q
    83         ;
    84 CHK469  ; Look through the current environment for valid Event/Elements for this patient.
    85         ;  Called from CHK463+19.
    86         ;
    87         Q:$G(OCXOERR)
    88         ;
    89         ;    Local CHK469 Variables
    90         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    91         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    92         ;
    93         ;      Local Extrinsic Functions
    94         ; FILE(DFN,131, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: GREATER THAN LAB THRESHOLD)
    95         ; PATLOC( ----------> PATIENT LOCATION
    96         ;
    97         S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,131,"12,37,96,113,147,152") Q:OCXOERR
    98         Q
    99         ;
    100 CHK476  ; Look through the current environment for valid Event/Elements for this patient.
    101         ;  Called from CHK463+20.
    102         ;
    103         Q:$G(OCXOERR)
    104         ;
    105         ;    Local CHK476 Variables
    106         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    107         ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
    108         ;
    109         ;      Local Extrinsic Functions
    110         ; FILE(DFN,132, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: LESS THAN LAB THRESHOLD)
    111         ; PATLOC( ----------> PATIENT LOCATION
    112         ;
    113         S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,132,"12,37,96,113,147,152") Q:OCXOERR
    114         Q
    115         ;
    116 ABREN(DFN)      ;  Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
    117         ;
    118         N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC
    119         S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>"
    120         S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV
    121         F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D  Q:($L(OCXLIST)>130)
    122         .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST)
    123         .S OCXTEST=0 F  S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST  D  Q:($L(OCXLIST)>130)
    124         ..S OCXSPEC=0 F  S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC  D  Q:($L(OCXLIST)>130)
    125         ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5)
    126         ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D
    127         ....N OCXY S OCXY=""
    128         ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4)
    129         ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"")
    130         ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P")
    131         ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY
    132         Q:'$L(OCXLIST) UNAV  Q 1_U_OCXLIST
    133         ; 
    134         ;
    135 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    136         ;
    137         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    138         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    139         ;
    140         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    141         ;
    142         S OCXDATA(DFN,OCXELE)=1
    143         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    144         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    145         ;
    146         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    147         ;
    148         Q 0
    149         ;
    150 LABTHRSB(OCXLAB,OCXSPEC,OCXRSLT,OCXOP)        ;  Compiler Function: LAB THRESHOLD EXCEEDED BOOLEAN
    151         ;
    152         S OCXRSLT=$TR($G(OCXRSLT),"<>=","")
    153         Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0
    154         ;
    155         N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD
    156         S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC
    157         D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
    158         Q:+$G(ORERR)'=0 OCXEXCD
    159         Q:+$G(OCXX)=0 OCXEXCD
    160         S OCXPENT="" F  S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1  D
    161         .S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
    162         .I $L(OCXPVAL) D
    163         ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D
    164         ...S OCXEXCD=1
    165         Q OCXEXCD
    166         ;
    167 ORDITEM(OIEN)   ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
    168         Q:'$G(OIEN) ""
    169         ;
    170         N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
    171         S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
    172         Q $P(X,U,1)
    173         ;
    174 PATLOC(DFN)     ;  Compiler Function: PATIENT LOCATION
    175         ;
    176         N OCXP1,OCXP2
    177         S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
    178         S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
    179         I OCXP2 D
    180         .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
    181         .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
    182         .E  S OCXP2=$P(OCXP2,"^",1)
    183         .S:'$L(OCXP2) OCXP2="NO LOC"
    184         I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
    185         ;
    186         S OCXP2=$G(^DPT(+$G(DFN),.1))
    187         I $L(OCXP2) Q "I^"_OCXP2
    188         Q "O^OUTPT"
    189         ;
    190 RECCREAT(ORDFN,ORDAYS)   ;extrinsic function to return most recent
    191         ;SERUM CREATININE within <ORDAYS> in format:
    192         ; test id^result units flag ref range collection d/t
    193         N BDT,CDT,ORY,ORX,ORZ,X,ORI,ORJ,CREARSLT,LABFILE,SPECFILE
    194         Q:'$L($G(ORDFN)) "0^"
    195         Q:'$L($G(ORDAYS)) "0^"
    196         D NOW^%DTC
    197         S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
    198         K %
    199         Q:'$L($G(BDT)) "0^"
    200         S LABFILE=$$TERMLKUP("SERUM CREATININE",.ORY)
    201         Q:$G(LABFILE)'=60 "0^"
    202         Q:+$D(ORY)<1 "0^"
    203         S SPECFILE=$$TERMLKUP("SERUM SPECIMEN",.ORX)
    204         Q:$G(SPECFILE)'=61 "0^"
    205         Q:+$D(ORX)<1 "0^"
    206         S ORI=0 F  S ORI=$O(ORY(ORI)) Q:'ORI  I +$G(CREARSLT)<1 D
    207         .S ORJ=0 F  S ORJ=$O(ORX(ORJ)) Q:'ORJ  I +$G(CREARSLT)<1 D
    208         ..S ORZ=$$LOCL^ORQQLR1(ORDFN,ORI,ORJ)
    209         ..Q:'$L($G(ORZ))
    210         ..S CDT=$P(ORZ,U,7)
    211         ..I CDT'<BDT S CREARSLT=1
    212         Q:+$G(CREARSLT)<1 "0^"
    213         Q $P(ORZ,U)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_")  "_$$FMTE^XLFDT(CDT,"2P")_U_$P(ORZ,U,3)
    214         ;
    215 TERMLKUP(OCXTERM,OCXLIST)       ;
    216         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    217         ;
     1OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK454 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK58+22^OCXOZ05.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK454 Variables
     19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     20 ; OCXDF(57) ---> Data Field: MOST RECENT RENAL TEST ABNORMAL FLAG (BOOLEAN)
     21 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT)
     22 ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC)
     23 ; OCXDF(155) --> Data Field: RECENT CONTRAST MEDIA CREATININE FLAG (BOOLEAN)
     24 ;
     25 ;      Local Extrinsic Functions
     26 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
     27 ; RECCREAT( --------> RECENT CREATININE LAB PROCEDURE
     28 ;
     29 S OCXDF(57)=$P($$ABREN(OCXDF(37)),"^",1) I $L(OCXDF(57)),(OCXDF(57)) S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) D CHK459
     30 S OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) I $L(OCXDF(154)) S OCXDF(155)=$P($$RECCREAT(OCXDF(37),OCXDF(154)),"^",1) I $L(OCXDF(155)),'(OCXDF(155)) D CHK490^OCXOZ0G
     31 Q
     32 ;
     33CHK459 ; Look through the current environment for valid Event/Elements for this patient.
     34 ;  Called from CHK454+16.
     35 ;
     36 Q:$G(OCXOERR)
     37 ;
     38 ;      Local Extrinsic Functions
     39 ; FILE(DFN,129, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: ABNORMAL RENAL RESULTS)
     40 ;
     41 S OCXOERR=$$FILE(DFN,129,"58,154") Q:OCXOERR
     42 Q
     43 ;
     44CHK466 ; Look through the current environment for valid Event/Elements for this patient.
     45 ;  Called from CHK196+18^OCXOZ09.
     46 ;
     47 Q:$G(OCXOERR)
     48 ;
     49 ;    Local CHK466 Variables
     50 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     51 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT)
     52 ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC)
     53 ;
     54 ;      Local Extrinsic Functions
     55 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
     56 ; FILE(DFN,130, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CONTRAST MEDIA ORDER)
     57 ;
     58 S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,130,"58,154") Q:OCXOERR
     59 Q
     60 ;
     61CHK471 ; Look through the current environment for valid Event/Elements for this patient.
     62 ;  Called from CHK1+34^OCXOZ02.
     63 ;
     64 Q:$G(OCXOERR)
     65 ;
     66 ;    Local CHK471 Variables
     67 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT)
     68 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC)
     69 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     70 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT)
     71 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC)
     72 ; OCXDF(150) --> Data Field: LAB RESULT < THRESHOLD (BOOLEAN)
     73 ; OCXDF(151) --> Data Field: LAB RESULT > THRESHOLD (BOOLEAN)
     74 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC)
     75 ;
     76 ;      Local Extrinsic Functions
     77 ; LABTHRSB( --------> LAB THRESHOLD EXCEEDED BOOLEAN
     78 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER
     79 ;
     80 S OCXDF(151)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),">"),"^",1) I $L(OCXDF(151)),(OCXDF(151)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK477
     81 S OCXDF(150)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),"<"),"^",1) I $L(OCXDF(150)),(OCXDF(150)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK484
     82 Q
     83 ;
     84CHK477 ; Look through the current environment for valid Event/Elements for this patient.
     85 ;  Called from CHK471+19.
     86 ;
     87 Q:$G(OCXOERR)
     88 ;
     89 ;    Local CHK477 Variables
     90 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     91 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     92 ;
     93 ;      Local Extrinsic Functions
     94 ; FILE(DFN,131, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: GREATER THAN LAB THRESHOLD)
     95 ; PATLOC( ----------> PATIENT LOCATION
     96 ;
     97 S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,131,"12,37,96,113,147,152") Q:OCXOERR
     98 Q
     99 ;
     100CHK484 ; Look through the current environment for valid Event/Elements for this patient.
     101 ;  Called from CHK471+20.
     102 ;
     103 Q:$G(OCXOERR)
     104 ;
     105 ;    Local CHK484 Variables
     106 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     107 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT)
     108 ;
     109 ;      Local Extrinsic Functions
     110 ; FILE(DFN,132, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: LESS THAN LAB THRESHOLD)
     111 ; PATLOC( ----------> PATIENT LOCATION
     112 ;
     113 S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,132,"12,37,96,113,147,152") Q:OCXOERR
     114 Q
     115 ;
     116ABREN(DFN) ;  Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
     117 ;
     118 N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC
     119 S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>"
     120 S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV
     121 F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D  Q:($L(OCXLIST)>130)
     122 .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST)
     123 .S OCXTEST=0 F  S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST  D  Q:($L(OCXLIST)>130)
     124 ..S OCXSPEC=0 F  S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC  D  Q:($L(OCXLIST)>130)
     125 ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5)
     126 ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D
     127 ....N OCXY S OCXY=""
     128 ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4)
     129 ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"")
     130 ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P")
     131 ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY
     132 Q:'$L(OCXLIST) UNAV  Q 1_U_OCXLIST
     133 ; 
     134 ;
     135FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     136 ;
     137 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     138 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     139 ;
     140 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     141 ;
     142 S OCXDATA(DFN,OCXELE)=1
     143 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     144 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     145 ;
     146 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     147 ;
     148 Q 0
     149 ;
     150LABTHRSB(OCXLAB,OCXSPEC,OCXRSLT,OCXOP)       ;  Compiler Function: LAB THRESHOLD EXCEEDED BOOLEAN
     151 ;
     152 Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0
     153 ;
     154 N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD
     155 S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC
     156 D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
     157 Q:+$G(ORERR)'=0 OCXEXCD
     158 Q:+$G(OCXX)=0 OCXEXCD
     159 S OCXPENT="" F  S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1  D
     160 .S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
     161 .I $L(OCXPVAL) D
     162 ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D
     163 ...S OCXEXCD=1
     164 Q OCXEXCD
     165 ;
     166ORDITEM(OIEN) ;  Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER
     167 Q:'$G(OIEN) ""
     168 ;
     169 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found."
     170 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found."
     171 Q $P(X,U,1)
     172 ;
     173PATLOC(DFN) ;  Compiler Function: PATIENT LOCATION
     174 ;
     175 N OCXP1,OCXP2
     176 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2))
     177 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1)
     178 I OCXP2 D
     179 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2)
     180 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2)
     181 .E  S OCXP2=$P(OCXP2,"^",1)
     182 .S:'$L(OCXP2) OCXP2="NO LOC"
     183 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2
     184 ;
     185 S OCXP2=$G(^DPT(+$G(DFN),.1))
     186 I $L(OCXP2) Q "I^"_OCXP2
     187 Q "O^OUTPT"
     188 ;
     189RECCREAT(ORDFN,ORDAYS)  ;extrinsic function to return most recent
     190 ;SERUM CREATININE within <ORDAYS> in format:
     191 ; test id^result units flag ref range collection d/t
     192 N BDT,CDT,ORY,ORX,ORZ,X,ORI,ORJ,CREARSLT,LABFILE,SPECFILE
     193 Q:'$L($G(ORDFN)) "0^"
     194 Q:'$L($G(ORDAYS)) "0^"
     195 D NOW^%DTC
     196 S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
     197 K %
     198 Q:'$L($G(BDT)) "0^"
     199 S LABFILE=$$TERMLKUP("SERUM CREATININE",.ORY)
     200 Q:$G(LABFILE)'=60 "0^"
     201 Q:+$D(ORY)<1 "0^"
     202 S SPECFILE=$$TERMLKUP("SERUM SPECIMEN",.ORX)
     203 Q:$G(SPECFILE)'=61 "0^"
     204 Q:+$D(ORX)<1 "0^"
     205 S ORI=0 F  S ORI=$O(ORY(ORI)) Q:'ORI  I +$G(CREARSLT)<1 D
     206 .S ORJ=0 F  S ORJ=$O(ORX(ORJ)) Q:'ORJ  I +$G(CREARSLT)<1 D
     207 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,ORI,ORJ)
     208 ..Q:'$L($G(ORZ))
     209 ..S CDT=$P(ORZ,U,7)
     210 ..I CDT'<BDT S CREARSLT=1
     211 Q:+$G(CREARSLT)<1 "0^"
     212 Q $P(ORZ,U)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_")  "_$$FMTE^XLFDT(CDT,"2P")_U_$P(ORZ,U,3)
     213 ;
     214TERMLKUP(OCXTERM,OCXLIST) ;
     215 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     216 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0G.m

    r613 r623  
    1 OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 CHK482  ; Look through the current environment for valid Event/Elements for this patient.
    14         ;  Called from CHK446+17^OCXOZ0F.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;    Local CHK482 Variables
    19         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    20         ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT)
    21         ;
    22         ;      Local Extrinsic Functions
    23         ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
    24         ; FILE(DFN,133, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NO CREAT RESULTS W/IN X DAYS)
    25         ;
    26         S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,133,"58,154") Q:OCXOERR
    27         Q
    28         ;
    29 CHK497  ; Look through the current environment for valid Event/Elements for this patient.
    30         ;  Called from CHK360+15^OCXOZ0D.
    31         ;
    32         Q:$G(OCXOERR)
    33         ;
    34         ;    Local CHK497 Variables
    35         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    36         ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT)
    37         ; OCXDF(158) --> Data Field: DUPLICATE OPIOID MEDICATIONS TEXT (FREE TEXT)
    38         ;
    39         ;      Local Extrinsic Functions
    40         ; LIST( ------------> IN LIST OPERATOR
    41         ; OPIOID( ----------> OPIOID MEDICATIONS
    42         ;
    43         I $$LIST(OCXDF(74),"OPIOID ANALGESICS,OPIOID ANTAGONIST ANALGESICS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2) D CHK501
    44         Q
    45         ;
    46 CHK501  ; Look through the current environment for valid Event/Elements for this patient.
    47         ;  Called from CHK497+14.
    48         ;
    49         Q:$G(OCXOERR)
    50         ;
    51         ;      Local Extrinsic Functions
    52         ; FILE(DFN,139, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: OPIOID MED ORDER)
    53         ;
    54         S OCXOERR=$$FILE(DFN,139,"158") Q:OCXOERR
    55         Q
    56         ;
    57 CHK505  ; Look through the current environment for valid Event/Elements for this patient.
    58         ;  Called from CHK355+14^OCXOZ0C.
    59         ;
    60         Q:$G(OCXOERR)
    61         ;
    62         ;    Local CHK505 Variables
    63         ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
    64         ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT)
    65         ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT)
    66         ;
    67         ;      Local Extrinsic Functions
    68         ; FILE(DFN,140, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: CLOZAPINE ANC >= 1.5 & < 2.0)
    69         ;
    70         S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,140,"130") Q:OCXOERR
    71         Q
    72         ;
    73 EL24    ; Examine every rule that involves Element #24 [HL7 LAB TEST RESULTS CRITICAL]
    74         ;  Called from SCAN+9^OCXOZ01.
    75         ;
    76         Q:$G(OCXOERR)
    77         ;
    78         D R3R1A^OCXOZ0I   ; Check Relation #1 in Rule #3 'CRITICAL LAB RESULTS'
    79         Q
    80         ;
    81 EL105   ; Examine every rule that involves Element #105 [HL7 LAB ORDER RESULTS CRITICAL]
    82         ;  Called from SCAN+9^OCXOZ01.
    83         ;
    84         Q:$G(OCXOERR)
    85         ;
    86         D R3R2A^OCXOZ0J   ; Check Relation #2 in Rule #3 'CRITICAL LAB RESULTS'
    87         Q
    88         ;
    89 EL44    ; Examine every rule that involves Element #44 [ORDER FLAGGED]
    90         ;  Called from SCAN+9^OCXOZ01.
    91         ;
    92         Q:$G(OCXOERR)
    93         ;
    94         D R5R1A^OCXOZ0J   ; Check Relation #1 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION'
    95         Q
    96         ;
    97 EL134   ; Examine every rule that involves Element #134 [ORDER UNFLAGGED]
    98         ;  Called from SCAN+9^OCXOZ01.
    99         ;
    100         Q:$G(OCXOERR)
    101         ;
    102         D R5R2A^OCXOZ0K   ; Check Relation #2 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION'
    103         Q
    104         ;
    105 EL45    ; Examine every rule that involves Element #45 [ORDER REQUIRES CHART SIGNATURE]
    106         ;  Called from SCAN+9^OCXOZ01.
    107         ;
    108         Q:$G(OCXOERR)
    109         ;
    110         D R6R1A^OCXOZ0K   ; Check Relation #1 in Rule #6 'ORDER REQUIRES CHART SIGNATURE'
    111         Q
    112         ;
    113 EL21    ; Examine every rule that involves Element #21 [PATIENT ADMISSION]
    114         ;  Called from SCAN+9^OCXOZ01.
    115         ;
    116         Q:$G(OCXOERR)
    117         ;
    118         D R7R1A^OCXOZ0K   ; Check Relation #1 in Rule #7 'PATIENT ADMISSION'
    119         Q
    120         ;
    121 EL31    ; Examine every rule that involves Element #31 [RADIOLOGY ORDER CANCELLED]
    122         ;  Called from SCAN+9^OCXOZ01.
    123         ;
    124         Q:$G(OCXOERR)
    125         ;
    126         D R11R1A^OCXOZ0L   ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
    127         Q
    128         ;
    129 EL100   ; Examine every rule that involves Element #100 [CANCELED BY NON-ORIG ORDERING PROVIDER]
    130         ;  Called from SCAN+9^OCXOZ01.
    131         ;
    132         Q:$G(OCXOERR)
    133         ;
    134         D R11R1A^OCXOZ0L   ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
    135         D R11R2A^OCXOZ0L   ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
    136         D R11R3A^OCXOZ0M   ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
    137         D R35R1A^OCXOZ0Q   ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'
    138         Q
    139         ;
    140 EL30    ; Examine every rule that involves Element #30 [RADIOLOGY ORDER PUT ON-HOLD]
    141         ;  Called from SCAN+9^OCXOZ01.
    142         ;
    143         Q:$G(OCXOERR)
    144         ;
    145         D R11R2A^OCXOZ0L   ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
    146         Q
    147         ;
    148 EL32    ; Examine every rule that involves Element #32 [RADIOLOGY ORDER DISCONTINUED]
    149         ;  Called from SCAN+9^OCXOZ01.
    150         ;
    151         Q:$G(OCXOERR)
    152         ;
    153         D R11R3A^OCXOZ0M   ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
    154         Q
    155         ;
    156 EL46    ; Examine every rule that involves Element #46 [SERVICE ORDER REQUIRES CHART SIGNATURE]
    157         ;  Called from SCAN+9^OCXOZ01.
    158         ;
    159         Q:$G(OCXOERR)
    160         ;
    161         D R16R1A^OCXOZ0M   ; Check Relation #1 in Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'
    162         Q
    163         ;
    164 EL76    ; Examine every rule that involves Element #76 [STAT LAB RESULT]
    165         ;  Called from SCAN+9^OCXOZ01.
    166         ;
    167         Q:$G(OCXOERR)
    168         ;
    169         D R18R1A^OCXOZ0M   ; Check Relation #1 in Rule #18 'STAT RESULTS AVAILABLE'
    170         Q
    171         ;
    172 EL75    ; Examine every rule that involves Element #75 [STAT IMAGING RESULT]
    173         ;  Called from SCAN+9^OCXOZ01.
    174         ;
    175         Q:$G(OCXOERR)
    176         ;
    177         D R18R2A^OCXOZ0N   ; Check Relation #2 in Rule #18 'STAT RESULTS AVAILABLE'
    178         Q
    179         ;
    180 EL110   ; Examine every rule that involves Element #110 [STAT CONSULT RESULT]
    181         ;  Called from SCAN+9^OCXOZ01.
    182         ;
    183         Q:$G(OCXOERR)
    184         ;
    185         D R18R3A^OCXOZ0N   ; Check Relation #3 in Rule #18 'STAT RESULTS AVAILABLE'
    186         Q
    187         ;
    188 ABREN(DFN)      ;  Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
    189         ;
    190         N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC
    191         S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>"
    192         S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV
    193         F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D  Q:($L(OCXLIST)>130)
    194         .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST)
    195         .S OCXTEST=0 F  S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST  D  Q:($L(OCXLIST)>130)
    196         ..S OCXSPEC=0 F  S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC  D  Q:($L(OCXLIST)>130)
    197         ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5)
    198         ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D
    199         ....N OCXY S OCXY=""
    200         ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4)
    201         ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"")
    202         ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P")
    203         ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY
    204         Q:'$L(OCXLIST) UNAV  Q 1_U_OCXLIST
    205         ; 
    206         ;
    207 FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
    208         ;
    209         N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
    210         S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
    211         ;
    212         Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
    213         ;
    214         S OCXDATA(DFN,OCXELE)=1
    215         F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
    216         .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
    217         ;
    218         M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
    219         ;
    220         Q 0
    221         ;
    222 LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
    223         ;
    224         S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
    225         Q (LIST[DATA)
    226         ;
    227 OPIOID(ORPT)    ;determine if pat is receiving opioid med
    228         ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ...
    229         N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN
    230         S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20
    231         K ^TMP("ORR",$J)
    232         S ORDG=$O(^ORD(100.98,"B","RX",ORDG))
    233         D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0)
    234         N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
    235         S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN
    236         F  S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1  D
    237         .S X=^TMP("ORR",$J,HOR,SEQ)
    238         .S ORNUM=+$P(X,";")
    239         .Q:ORNUM=+$G(ORIFN)  ;quit if dup med order # = current order #
    240         .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG")
    241         .I +$G(ORDI)>0 D
    242         ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2)  ;va drug class
    243         ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D  ;opioid classes
    244         ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM)
    245         ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]"
    246         ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT
    247         ...S ORTN=1
    248         I DUPI>0 D
    249         .S DUPLEN=$P(215/DUPI,".")
    250         .F DUPJ=1:1:DUPI D
    251         ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN)
    252         ..E  S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN)
    253         K ^TMP("ORR",$J)
    254         Q ORTN_U_$G(ORDERS)
    255         ;
    256 TERMLKUP(OCXTERM,OCXLIST)       ;
    257         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    258         ;
     1OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13CHK490 ; Look through the current environment for valid Event/Elements for this patient.
     14 ;  Called from CHK454+17^OCXOZ0F.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;    Local CHK490 Variables
     19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     20 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT)
     21 ;
     22 ;      Local Extrinsic Functions
     23 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
     24 ; FILE(DFN,133, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: NO CREAT RESULTS W/IN X DAYS)
     25 ;
     26 S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,133,"58,154") Q:OCXOERR
     27 Q
     28 ;
     29CHK505 ; Look through the current environment for valid Event/Elements for this patient.
     30 ;  Called from CHK362+15^OCXOZ0D.
     31 ;
     32 Q:$G(OCXOERR)
     33 ;
     34 ;    Local CHK505 Variables
     35 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC)
     36 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT)
     37 ; OCXDF(158) --> Data Field: DUPLICATE OPIOID MEDICATIONS TEXT (FREE TEXT)
     38 ;
     39 ;      Local Extrinsic Functions
     40 ; LIST( ------------> IN LIST OPERATOR
     41 ; OPIOID( ----------> OPIOID MEDICATIONS
     42 ;
     43 I $$LIST(OCXDF(74),"OPIOID ANALGESICS,OPIOID ANTAGONIST ANALGESICS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2) D CHK509
     44 Q
     45 ;
     46CHK509 ; Look through the current environment for valid Event/Elements for this patient.
     47 ;  Called from CHK505+14.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 ;      Local Extrinsic Functions
     52 ; FILE(DFN,139, ----> FILE DATA IN PATIENT ACTIVE DATA FILE  (Event/Element: OPIOID MED ORDER)
     53 ;
     54 S OCXOERR=$$FILE(DFN,139,"158") Q:OCXOERR
     55 Q
     56 ;
     57EL24 ; Examine every rule that involves Element #24 [HL7 LAB TEST RESULTS CRITICAL]
     58 ;  Called from SCAN+9^OCXOZ01.
     59 ;
     60 Q:$G(OCXOERR)
     61 ;
     62 D R3R1A^OCXOZ0I   ; Check Relation #1 in Rule #3 'CRITICAL LAB RESULTS'
     63 Q
     64 ;
     65EL105 ; Examine every rule that involves Element #105 [HL7 LAB ORDER RESULTS CRITICAL]
     66 ;  Called from SCAN+9^OCXOZ01.
     67 ;
     68 Q:$G(OCXOERR)
     69 ;
     70 D R3R2A^OCXOZ0J   ; Check Relation #2 in Rule #3 'CRITICAL LAB RESULTS'
     71 Q
     72 ;
     73EL44 ; Examine every rule that involves Element #44 [ORDER FLAGGED]
     74 ;  Called from SCAN+9^OCXOZ01.
     75 ;
     76 Q:$G(OCXOERR)
     77 ;
     78 D R5R1A^OCXOZ0J   ; Check Relation #1 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION'
     79 Q
     80 ;
     81EL134 ; Examine every rule that involves Element #134 [ORDER UNFLAGGED]
     82 ;  Called from SCAN+9^OCXOZ01.
     83 ;
     84 Q:$G(OCXOERR)
     85 ;
     86 D R5R2A^OCXOZ0K   ; Check Relation #2 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION'
     87 Q
     88 ;
     89EL45 ; Examine every rule that involves Element #45 [ORDER REQUIRES CHART SIGNATURE]
     90 ;  Called from SCAN+9^OCXOZ01.
     91 ;
     92 Q:$G(OCXOERR)
     93 ;
     94 D R6R1A^OCXOZ0K   ; Check Relation #1 in Rule #6 'ORDER REQUIRES CHART SIGNATURE'
     95 Q
     96 ;
     97EL21 ; Examine every rule that involves Element #21 [PATIENT ADMISSION]
     98 ;  Called from SCAN+9^OCXOZ01.
     99 ;
     100 Q:$G(OCXOERR)
     101 ;
     102 D R7R1A^OCXOZ0K   ; Check Relation #1 in Rule #7 'PATIENT ADMISSION'
     103 Q
     104 ;
     105EL31 ; Examine every rule that involves Element #31 [RADIOLOGY ORDER CANCELLED]
     106 ;  Called from SCAN+9^OCXOZ01.
     107 ;
     108 Q:$G(OCXOERR)
     109 ;
     110 D R11R1A^OCXOZ0L   ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
     111 Q
     112 ;
     113EL100 ; Examine every rule that involves Element #100 [CANCELED BY NON-ORIG ORDERING PROVIDER]
     114 ;  Called from SCAN+9^OCXOZ01.
     115 ;
     116 Q:$G(OCXOERR)
     117 ;
     118 D R11R1A^OCXOZ0L   ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
     119 D R11R2A^OCXOZ0L   ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
     120 D R11R3A^OCXOZ0M   ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
     121 D R35R1A^OCXOZ0Q   ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'
     122 Q
     123 ;
     124EL30 ; Examine every rule that involves Element #30 [RADIOLOGY ORDER PUT ON-HOLD]
     125 ;  Called from SCAN+9^OCXOZ01.
     126 ;
     127 Q:$G(OCXOERR)
     128 ;
     129 D R11R2A^OCXOZ0L   ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
     130 Q
     131 ;
     132EL32 ; Examine every rule that involves Element #32 [RADIOLOGY ORDER DISCONTINUED]
     133 ;  Called from SCAN+9^OCXOZ01.
     134 ;
     135 Q:$G(OCXOERR)
     136 ;
     137 D R11R3A^OCXOZ0M   ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'
     138 Q
     139 ;
     140EL46 ; Examine every rule that involves Element #46 [SERVICE ORDER REQUIRES CHART SIGNATURE]
     141 ;  Called from SCAN+9^OCXOZ01.
     142 ;
     143 Q:$G(OCXOERR)
     144 ;
     145 D R16R1A^OCXOZ0M   ; Check Relation #1 in Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'
     146 Q
     147 ;
     148EL76 ; Examine every rule that involves Element #76 [STAT LAB RESULT]
     149 ;  Called from SCAN+9^OCXOZ01.
     150 ;
     151 Q:$G(OCXOERR)
     152 ;
     153 D R18R1A^OCXOZ0M   ; Check Relation #1 in Rule #18 'STAT RESULTS AVAILABLE'
     154 Q
     155 ;
     156EL75 ; Examine every rule that involves Element #75 [STAT IMAGING RESULT]
     157 ;  Called from SCAN+9^OCXOZ01.
     158 ;
     159 Q:$G(OCXOERR)
     160 ;
     161 D R18R2A^OCXOZ0N   ; Check Relation #2 in Rule #18 'STAT RESULTS AVAILABLE'
     162 Q
     163 ;
     164EL110 ; Examine every rule that involves Element #110 [STAT CONSULT RESULT]
     165 ;  Called from SCAN+9^OCXOZ01.
     166 ;
     167 Q:$G(OCXOERR)
     168 ;
     169 D R18R3A^OCXOZ0N   ; Check Relation #3 in Rule #18 'STAT RESULTS AVAILABLE'
     170 Q
     171 ;
     172EL56 ; Examine every rule that involves Element #56 [PATIENT DISCHARGE]
     173 ;  Called from SCAN+9^OCXOZ01.
     174 ;
     175 Q:$G(OCXOERR)
     176 ;
     177 D R19R1A^OCXOZ0N   ; Check Relation #1 in Rule #19 'PATIENT DISCHARGE'
     178 Q
     179 ;
     180EL47 ; Examine every rule that involves Element #47 [ORDER REQUIRES CO-SIGNATURE]
     181 ;  Called from SCAN+9^OCXOZ01.
     182 ;
     183 Q:$G(OCXOERR)
     184 ;
     185 D R22R1A^OCXOZ0O   ; Check Relation #1 in Rule #22 'ORDER REQUIRES CO-SIGNATURE'
     186 Q
     187 ;
     188ABREN(DFN) ;  Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW
     189 ;
     190 N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC
     191 S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>"
     192 S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV
     193 F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D  Q:($L(OCXLIST)>130)
     194 .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST)
     195 .S OCXTEST=0 F  S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST  D  Q:($L(OCXLIST)>130)
     196 ..S OCXSPEC=0 F  S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC  D  Q:($L(OCXLIST)>130)
     197 ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5)
     198 ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D
     199 ....N OCXY S OCXY=""
     200 ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4)
     201 ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"")
     202 ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P")
     203 ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY
     204 Q:'$L(OCXLIST) UNAV  Q 1_U_OCXLIST
     205 ; 
     206 ;
     207FILE(DFN,OCXELE,OCXDFL) ;     This Local Extrinsic Function logs a validated event/element.
     208 ;
     209 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI
     210 S DFN=+$G(DFN),OCXELE=+$G(OCXELE)
     211 ;
     212 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA
     213 ;
     214 S OCXDATA(DFN,OCXELE)=1
     215 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D
     216 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL
     217 ;
     218 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN)
     219 ;
     220 Q 0
     221 ;
     222LIST(DATA,LIST) ;   IS THE DATA FIELD IN THE LIST
     223 ;
     224 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_","
     225 Q (LIST[DATA)
     226 ;
     227OPIOID(ORPT) ;determine if pat is receiving opioid med
     228 ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ...
     229 N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN
     230 S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20
     231 K ^TMP("ORR",$J)
     232 S ORDG=$O(^ORD(100.98,"B","RX",ORDG))
     233 D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0)
     234 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
     235 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN
     236 F  S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1  D
     237 .S X=^TMP("ORR",$J,HOR,SEQ)
     238 .S ORNUM=+$P(X,";")
     239 .Q:ORNUM=+$G(ORIFN)  ;quit if dup med order # = current order #
     240 .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG")
     241 .I +$G(ORDI)>0 D
     242 ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2)  ;va drug class
     243 ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D  ;opioid classes
     244 ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM)
     245 ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]"
     246 ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT
     247 ...S ORTN=1
     248 I DUPI>0 D
     249 .S DUPLEN=$P(215/DUPI,".")
     250 .F DUPJ=1:1:DUPI D
     251 ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN)
     252 ..E  S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN)
     253 K ^TMP("ORR",$J)
     254 Q ORTN_U_$G(ORDERS)
     255 ;
     256TERMLKUP(OCXTERM,OCXLIST) ;
     257 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     258 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m

    r613 r623  
    1 OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 EL56    ; Examine every rule that involves Element #56 [PATIENT DISCHARGE]
    14         ;  Called from SCAN+9^OCXOZ01.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         D R19R1A^OCXOZ0N   ; Check Relation #1 in Rule #19 'PATIENT DISCHARGE'
    19         Q
    20         ;
    21 EL47    ; Examine every rule that involves Element #47 [ORDER REQUIRES CO-SIGNATURE]
    22         ;  Called from SCAN+9^OCXOZ01.
    23         ;
    24         Q:$G(OCXOERR)
    25         ;
    26         D R22R1A^OCXOZ0O   ; Check Relation #1 in Rule #22 'ORDER REQUIRES CO-SIGNATURE'
    27         Q
    28         ;
    29 EL5     ; Examine every rule that involves Element #5 [HL7 FINAL LAB RESULT]
    30         ;  Called from SCAN+9^OCXOZ01.
    31         ;
    32         Q:$G(OCXOERR)
    33         ;
    34         D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
    35         D R66R1A^OCXOZ0Z   ; Check Relation #1 in Rule #66 'LAB RESULTS'
    36         D R69R1A^OCXOZ11   ; Check Relation #1 in Rule #69 'LAB THRESHOLD'
    37         Q
    38         ;
    39 EL49    ; Examine every rule that involves Element #49 [ORDER FLAGGED FOR RESULTS]
    40         ;  Called from SCAN+9^OCXOZ01.
    41         ;
    42         Q:$G(OCXOERR)
    43         ;
    44         D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
    45         Q
    46         ;
    47 EL55    ; Examine every rule that involves Element #55 [CONSULT FINAL RESULTS]
    48         ;  Called from SCAN+9^OCXOZ01.
    49         ;
    50         Q:$G(OCXOERR)
    51         ;
    52         D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
    53         Q
    54         ;
    55 EL101   ; Examine every rule that involves Element #101 [HL7 FINAL IMAGING RESULT]
    56         ;  Called from SCAN+9^OCXOZ01.
    57         ;
    58         Q:$G(OCXOERR)
    59         ;
    60         D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
    61         Q
    62         ;
    63 EL60    ; Examine every rule that involves Element #60 [NEW OBR STAT ORDER]
    64         ;  Called from SCAN+9^OCXOZ01.
    65         ;
    66         Q:$G(OCXOERR)
    67         ;
    68         D R28R1A^OCXOZ0P   ; Check Relation #1 in Rule #28 'STAT ORDER PLACED'
    69         Q
    70         ;
    71 EL61    ; Examine every rule that involves Element #61 [NEW ORC STAT ORDER]
    72         ;  Called from SCAN+9^OCXOZ01.
    73         ;
    74         Q:$G(OCXOERR)
    75         ;
    76         D R28R1A^OCXOZ0P   ; Check Relation #1 in Rule #28 'STAT ORDER PLACED'
    77         Q
    78         ;
    79 EL42    ; Examine every rule that involves Element #42 [PATIENT TRANSFERRED FROM PSYCH WARD]
    80         ;  Called from SCAN+9^OCXOZ01.
    81         ;
    82         Q:$G(OCXOERR)
    83         ;
    84         D R32R1A^OCXOZ0P   ; Check Relation #1 in Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO ANOTHER UNIT'
    85         Q
    86         ;
    87 EL20    ; Examine every rule that involves Element #20 [HL7 LAB ORDER CANCELLED]
    88         ;  Called from SCAN+9^OCXOZ01.
    89         ;
    90         Q:$G(OCXOERR)
    91         ;
    92         D R35R1A^OCXOZ0Q   ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'
    93         Q
    94         ;
    95 EL40    ; Examine every rule that involves Element #40 [HL7 LAB REQUEST CANCELLED]
    96         ;  Called from SCAN+9^OCXOZ01.
    97         ;
    98         Q:$G(OCXOERR)
    99         ;
    100         D R35R1A^OCXOZ0Q   ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'
    101         Q
    102         ;
    103 EL6     ; Examine every rule that involves Element #6 [HL7 NEW OERR ORDER]
    104         ;  Called from SCAN+9^OCXOZ01.
    105         ;
    106         Q:$G(OCXOERR)
    107         ;
    108         D R38R1A^OCXOZ0Q   ; Check Relation #1 in Rule #38 'NEW ORDER PLACED'
    109         Q
    110         ;
    111 EL126   ; Examine every rule that involves Element #126 [HL7 DCED OERR ORDER]
    112         ;  Called from SCAN+9^OCXOZ01.
    113         ;
    114         Q:$G(OCXOERR)
    115         ;
    116         D R38R2A^OCXOZ0Q   ; Check Relation #2 in Rule #38 'NEW ORDER PLACED'
    117         Q
    118         ;
    119 EL23    ; Examine every rule that involves Element #23 [HL7 LAB ORDER RESULTS ABNORMAL]
    120         ;  Called from SCAN+9^OCXOZ01.
    121         ;
    122         Q:$G(OCXOERR)
    123         ;
    124         D R42R1A^OCXOZ0R   ; Check Relation #1 in Rule #42 'ABNORMAL LAB RESULTS'
    125         Q
    126         ;
    127 EL103   ; Examine every rule that involves Element #103 [HL7 LAB TEST RESULTS ABNORMAL]
    128         ;  Called from SCAN+9^OCXOZ01.
    129         ;
    130         Q:$G(OCXOERR)
    131         ;
    132         D R42R2A^OCXOZ0R   ; Check Relation #2 in Rule #42 'ABNORMAL LAB RESULTS'
    133         Q
    134         ;
    135 EL48    ; Examine every rule that involves Element #48 [ORDER REQUIRES ELECTRONIC SIGNATURE]
    136         ;  Called from SCAN+9^OCXOZ01.
    137         ;
    138         Q:$G(OCXOERR)
    139         ;
    140         D R44R1A^OCXOZ0R   ; Check Relation #1 in Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE'
    141         Q
    142         ;
    143 EL58    ; Examine every rule that involves Element #58 [NEW SITE FLAGGED ORDER]
    144         ;  Called from SCAN+9^OCXOZ01.
    145         ;
    146         Q:$G(OCXOERR)
    147         ;
    148         D R48R1A^OCXOZ0S   ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER'
    149         D R48R2A^OCXOZ0S   ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER'
    150         Q
    151         ;
    152 EL127   ; Examine every rule that involves Element #127 [INPATIENT]
    153         ;  Called from SCAN+9^OCXOZ01.
    154         ;
    155         Q:$G(OCXOERR)
    156         ;
    157         D R48R1A^OCXOZ0S   ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER'
    158         D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
    159         Q
    160         ;
    161 EL128   ; Examine every rule that involves Element #128 [OUTPATIENT]
    162         ;  Called from SCAN+9^OCXOZ01.
    163         ;
    164         Q:$G(OCXOERR)
    165         ;
    166         D R48R2A^OCXOZ0S   ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER'
    167         D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
    168         Q
    169         ;
    170 EL59    ; Examine every rule that involves Element #59 [SITE FLAGGED FINAL LAB RESULT]
    171         ;  Called from SCAN+9^OCXOZ01.
    172         ;
    173         Q:$G(OCXOERR)
    174         ;
    175         D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
    176         D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
    177         Q
    178         ;
    179 EL102   ; Examine every rule that involves Element #102 [SITE FLAGGED FINAL IMAGING RESULT]
    180         ;  Called from SCAN+9^OCXOZ01.
    181         ;
    182         Q:$G(OCXOERR)
    183         ;
    184         D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
    185         D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
    186         Q
    187         ;
    188 EL109   ; Examine every rule that involves Element #109 [SITE FLAGGED FINAL CONSULT RESULT]
    189         ;  Called from SCAN+9^OCXOZ01.
    190         ;
    191         Q:$G(OCXOERR)
    192         ;
    193         D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
    194         D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
    195         Q
    196         ;
    197 EL129   ; Examine every rule that involves Element #129 [ABNORMAL RENAL RESULTS]
    198         ;  Called from SCAN+9^OCXOZ01.
    199         ;
    200         Q:$G(OCXOERR)
    201         ;
    202         D R50R1A^OCXOZ0U   ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
    203         Q
    204         ;
    205 EL130   ; Examine every rule that involves Element #130 [CONTRAST MEDIA ORDER]
    206         ;  Called from SCAN+9^OCXOZ01.
    207         ;
    208         Q:$G(OCXOERR)
    209         ;
    210         D R50R1A^OCXOZ0U   ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
    211         D R50R2A^OCXOZ0V   ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
    212         Q
    213         ;
    214 EL133   ; Examine every rule that involves Element #133 [NO CREAT RESULTS W/IN X DAYS]
    215         ;  Called from SCAN+9^OCXOZ01.
    216         ;
    217         Q:$G(OCXOERR)
    218         ;
    219         D R50R2A^OCXOZ0V   ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
    220         Q
    221         ;
    222 EL63    ; Examine every rule that involves Element #63 [PATIENT HAS RECENT CHOLECYSTOGRAM]
    223         ;  Called from SCAN+9^OCXOZ01.
    224         ;
    225         Q:$G(OCXOERR)
    226         ;
    227         D R51R1A^OCXOZ0V   ; Check Relation #1 in Rule #51 'RECENT CHOLECYSTOGRAM ORDER'
    228         Q
    229         ;
    230 EL64    ; Examine every rule that involves Element #64 [PHARMACY PATIENT OVER 65]
    231         ;  Called from SCAN+9^OCXOZ01.
    232         ;
    233         Q:$G(OCXOERR)
    234         ;
    235         D R53R1A^OCXOZ0V   ; Check Relation #1 in Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK'
    236         Q
    237         ;
    238 EL65    ; Examine every rule that involves Element #65 [SESSION ORDER FOR ANGIOGRAM]
    239         ;  Called from SCAN+9^OCXOZ01.
    240         ;
    241         Q:$G(OCXOERR)
    242         ;
    243         D R54R1A^OCXOZ0V   ; Check Relation #1 in Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CATH - PERIPHERAL'
    244         Q
    245         ;
    246 EL66    ; Examine every rule that involves Element #66 [CONTRAST MEDIA ALLERGY]
    247         ;  Called from SCAN+9^OCXOZ01.
    248         ;
    249         Q:$G(OCXOERR)
    250         ;
    251         D R55R1A^OCXOZ0V   ; Check Relation #1 in Rule #55 'ALLERGY - CONTRAST MEDIA REACTION'
    252         Q
    253         ;
    254 EL67    ; Examine every rule that involves Element #67 [RECENT BARIUM STUDY ORDERED]
    255         ;  Called from SCAN+9^OCXOZ01.
    256         ;
    257         Q:$G(OCXOERR)
    258         ;
    259         D R56R1A^OCXOZ0W   ; Check Relation #1 in Rule #56 'RECENT BARIUM STUDY'
    260         Q
    261         ;
    262 EL116   ; Examine every rule that involves Element #116 [CLOZAPINE DRUG SELECTED]
    263         ;  Called from SCAN+9^OCXOZ01.
    264         ;
    265         Q:$G(OCXOERR)
    266         ;
    267         D R57R1A^OCXOZ0W   ; Check Relation #1 in Rule #57 'CLOZAPINE'
    268         D R57R2A^OCXOZ0W   ; Check Relation #2 in Rule #57 'CLOZAPINE'
    269         D R57R3A^OCXOZ0W   ; Check Relation #3 in Rule #57 'CLOZAPINE'
    270         D R57R4A^OCXOZ0W   ; Check Relation #4 in Rule #57 'CLOZAPINE'
    271         Q
    272         ;
    273 EL117   ; Examine every rule that involves Element #117 [CLOZAPINE NO ANC W/IN 7 DAYS]
    274         ;  Called from SCAN+9^OCXOZ01.
    275         ;
    276         Q:$G(OCXOERR)
    277         ;
    278         D R57R1A^OCXOZ0W   ; Check Relation #1 in Rule #57 'CLOZAPINE'
    279         Q
    280         ;
    281 EL118   ; Examine every rule that involves Element #118 [CLOZAPINE NO WBC W/IN 7 DAYS]
    282         ;  Called from SCAN+9^OCXOZ01.
    283         ;
    284         Q:$G(OCXOERR)
    285         ;
    286         D R57R1A^OCXOZ0W   ; Check Relation #1 in Rule #57 'CLOZAPINE'
    287         Q
    288         ;
     1OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13EL5 ; Examine every rule that involves Element #5 [HL7 FINAL LAB RESULT]
     14 ;  Called from SCAN+9^OCXOZ01.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
     19 D R66R1A^OCXOZ0Z   ; Check Relation #1 in Rule #66 'LAB RESULTS'
     20 D R69R1A^OCXOZ11   ; Check Relation #1 in Rule #69 'LAB THRESHOLD'
     21 Q
     22 ;
     23EL49 ; Examine every rule that involves Element #49 [ORDER FLAGGED FOR RESULTS]
     24 ;  Called from SCAN+9^OCXOZ01.
     25 ;
     26 Q:$G(OCXOERR)
     27 ;
     28 D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
     29 Q
     30 ;
     31EL55 ; Examine every rule that involves Element #55 [CONSULT FINAL RESULTS]
     32 ;  Called from SCAN+9^OCXOZ01.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
     37 Q
     38 ;
     39EL101 ; Examine every rule that involves Element #101 [HL7 FINAL IMAGING RESULT]
     40 ;  Called from SCAN+9^OCXOZ01.
     41 ;
     42 Q:$G(OCXOERR)
     43 ;
     44 D R24R1A^OCXOZ0O   ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'
     45 Q
     46 ;
     47EL60 ; Examine every rule that involves Element #60 [NEW OBR STAT ORDER]
     48 ;  Called from SCAN+9^OCXOZ01.
     49 ;
     50 Q:$G(OCXOERR)
     51 ;
     52 D R28R1A^OCXOZ0P   ; Check Relation #1 in Rule #28 'STAT ORDER PLACED'
     53 Q
     54 ;
     55EL61 ; Examine every rule that involves Element #61 [NEW ORC STAT ORDER]
     56 ;  Called from SCAN+9^OCXOZ01.
     57 ;
     58 Q:$G(OCXOERR)
     59 ;
     60 D R28R1A^OCXOZ0P   ; Check Relation #1 in Rule #28 'STAT ORDER PLACED'
     61 Q
     62 ;
     63EL42 ; Examine every rule that involves Element #42 [PATIENT TRANSFERRED FROM PSYCH WARD]
     64 ;  Called from SCAN+9^OCXOZ01.
     65 ;
     66 Q:$G(OCXOERR)
     67 ;
     68 D R32R1A^OCXOZ0P   ; Check Relation #1 in Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO ANOTHER UNIT'
     69 Q
     70 ;
     71EL20 ; Examine every rule that involves Element #20 [HL7 LAB ORDER CANCELLED]
     72 ;  Called from SCAN+9^OCXOZ01.
     73 ;
     74 Q:$G(OCXOERR)
     75 ;
     76 D R35R1A^OCXOZ0Q   ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'
     77 Q
     78 ;
     79EL40 ; Examine every rule that involves Element #40 [HL7 LAB REQUEST CANCELLED]
     80 ;  Called from SCAN+9^OCXOZ01.
     81 ;
     82 Q:$G(OCXOERR)
     83 ;
     84 D R35R1A^OCXOZ0Q   ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'
     85 Q
     86 ;
     87EL6 ; Examine every rule that involves Element #6 [HL7 NEW OERR ORDER]
     88 ;  Called from SCAN+9^OCXOZ01.
     89 ;
     90 Q:$G(OCXOERR)
     91 ;
     92 D R38R1A^OCXOZ0Q   ; Check Relation #1 in Rule #38 'NEW ORDER PLACED'
     93 Q
     94 ;
     95EL126 ; Examine every rule that involves Element #126 [HL7 DCED OERR ORDER]
     96 ;  Called from SCAN+9^OCXOZ01.
     97 ;
     98 Q:$G(OCXOERR)
     99 ;
     100 D R38R2A^OCXOZ0Q   ; Check Relation #2 in Rule #38 'NEW ORDER PLACED'
     101 Q
     102 ;
     103EL23 ; Examine every rule that involves Element #23 [HL7 LAB ORDER RESULTS ABNORMAL]
     104 ;  Called from SCAN+9^OCXOZ01.
     105 ;
     106 Q:$G(OCXOERR)
     107 ;
     108 D R42R1A^OCXOZ0R   ; Check Relation #1 in Rule #42 'ABNORMAL LAB RESULTS'
     109 Q
     110 ;
     111EL103 ; Examine every rule that involves Element #103 [HL7 LAB TEST RESULTS ABNORMAL]
     112 ;  Called from SCAN+9^OCXOZ01.
     113 ;
     114 Q:$G(OCXOERR)
     115 ;
     116 D R42R2A^OCXOZ0R   ; Check Relation #2 in Rule #42 'ABNORMAL LAB RESULTS'
     117 Q
     118 ;
     119EL48 ; Examine every rule that involves Element #48 [ORDER REQUIRES ELECTRONIC SIGNATURE]
     120 ;  Called from SCAN+9^OCXOZ01.
     121 ;
     122 Q:$G(OCXOERR)
     123 ;
     124 D R44R1A^OCXOZ0R   ; Check Relation #1 in Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE'
     125 Q
     126 ;
     127EL58 ; Examine every rule that involves Element #58 [NEW SITE FLAGGED ORDER]
     128 ;  Called from SCAN+9^OCXOZ01.
     129 ;
     130 Q:$G(OCXOERR)
     131 ;
     132 D R48R1A^OCXOZ0S   ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER'
     133 D R48R2A^OCXOZ0S   ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER'
     134 Q
     135 ;
     136EL127 ; Examine every rule that involves Element #127 [INPATIENT]
     137 ;  Called from SCAN+9^OCXOZ01.
     138 ;
     139 Q:$G(OCXOERR)
     140 ;
     141 D R48R1A^OCXOZ0S   ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER'
     142 D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
     143 Q
     144 ;
     145EL128 ; Examine every rule that involves Element #128 [OUTPATIENT]
     146 ;  Called from SCAN+9^OCXOZ01.
     147 ;
     148 Q:$G(OCXOERR)
     149 ;
     150 D R48R2A^OCXOZ0S   ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER'
     151 D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
     152 Q
     153 ;
     154EL59 ; Examine every rule that involves Element #59 [SITE FLAGGED FINAL LAB RESULT]
     155 ;  Called from SCAN+9^OCXOZ01.
     156 ;
     157 Q:$G(OCXOERR)
     158 ;
     159 D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
     160 D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
     161 Q
     162 ;
     163EL102 ; Examine every rule that involves Element #102 [SITE FLAGGED FINAL IMAGING RESULT]
     164 ;  Called from SCAN+9^OCXOZ01.
     165 ;
     166 Q:$G(OCXOERR)
     167 ;
     168 D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
     169 D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
     170 Q
     171 ;
     172EL109 ; Examine every rule that involves Element #109 [SITE FLAGGED FINAL CONSULT RESULT]
     173 ;  Called from SCAN+9^OCXOZ01.
     174 ;
     175 Q:$G(OCXOERR)
     176 ;
     177 D R49R1A^OCXOZ0T   ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT'
     178 D R49R2A^OCXOZ0U   ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT'
     179 Q
     180 ;
     181EL129 ; Examine every rule that involves Element #129 [ABNORMAL RENAL RESULTS]
     182 ;  Called from SCAN+9^OCXOZ01.
     183 ;
     184 Q:$G(OCXOERR)
     185 ;
     186 D R50R1A^OCXOZ0U   ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
     187 Q
     188 ;
     189EL130 ; Examine every rule that involves Element #130 [CONTRAST MEDIA ORDER]
     190 ;  Called from SCAN+9^OCXOZ01.
     191 ;
     192 Q:$G(OCXOERR)
     193 ;
     194 D R50R1A^OCXOZ0U   ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
     195 D R50R2A^OCXOZ0V   ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
     196 Q
     197 ;
     198EL133 ; Examine every rule that involves Element #133 [NO CREAT RESULTS W/IN X DAYS]
     199 ;  Called from SCAN+9^OCXOZ01.
     200 ;
     201 Q:$G(OCXOERR)
     202 ;
     203 D R50R2A^OCXOZ0V   ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK'
     204 Q
     205 ;
     206EL63 ; Examine every rule that involves Element #63 [PATIENT HAS RECENT CHOLECYSTOGRAM]
     207 ;  Called from SCAN+9^OCXOZ01.
     208 ;
     209 Q:$G(OCXOERR)
     210 ;
     211 D R51R1A^OCXOZ0V   ; Check Relation #1 in Rule #51 'RECENT CHOLECYSTOGRAM ORDER'
     212 Q
     213 ;
     214EL64 ; Examine every rule that involves Element #64 [PHARMACY PATIENT OVER 65]
     215 ;  Called from SCAN+9^OCXOZ01.
     216 ;
     217 Q:$G(OCXOERR)
     218 ;
     219 D R53R1A^OCXOZ0V   ; Check Relation #1 in Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK'
     220 Q
     221 ;
     222EL65 ; Examine every rule that involves Element #65 [SESSION ORDER FOR ANGIOGRAM]
     223 ;  Called from SCAN+9^OCXOZ01.
     224 ;
     225 Q:$G(OCXOERR)
     226 ;
     227 D R54R1A^OCXOZ0V   ; Check Relation #1 in Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CATH - PERIPHERAL'
     228 Q
     229 ;
     230EL66 ; Examine every rule that involves Element #66 [CONTRAST MEDIA ALLERGY]
     231 ;  Called from SCAN+9^OCXOZ01.
     232 ;
     233 Q:$G(OCXOERR)
     234 ;
     235 D R55R1A^OCXOZ0V   ; Check Relation #1 in Rule #55 'ALLERGY - CONTRAST MEDIA REACTION'
     236 Q
     237 ;
     238EL67 ; Examine every rule that involves Element #67 [RECENT BARIUM STUDY ORDERED]
     239 ;  Called from SCAN+9^OCXOZ01.
     240 ;
     241 Q:$G(OCXOERR)
     242 ;
     243 D R56R1A^OCXOZ0W   ; Check Relation #1 in Rule #56 'RECENT BARIUM STUDY'
     244 Q
     245 ;
     246EL114 ; Examine every rule that involves Element #114 [CLOZAPINE ANC < 1.5]
     247 ;  Called from SCAN+9^OCXOZ01.
     248 ;
     249 Q:$G(OCXOERR)
     250 ;
     251 D R57R1A^OCXOZ0W   ; Check Relation #1 in Rule #57 'CLOZAPINE'
     252 Q
     253 ;
     254EL116 ; Examine every rule that involves Element #116 [CLOZAPINE DRUG SELECTED]
     255 ;  Called from SCAN+9^OCXOZ01.
     256 ;
     257 Q:$G(OCXOERR)
     258 ;
     259 D R57R1A^OCXOZ0W   ; Check Relation #1 in Rule #57 'CLOZAPINE'
     260 D R57R2A^OCXOZ0W   ; Check Relation #2 in Rule #57 'CLOZAPINE'
     261 D R57R3A^OCXOZ0W   ; Check Relation #3 in Rule #57 'CLOZAPINE'
     262 D R57R4A^OCXOZ0W   ; Check Relation #4 in Rule #57 'CLOZAPINE'
     263 D R57R5A^OCXOZ0X   ; Check Relation #5 in Rule #57 'CLOZAPINE'
     264 Q
     265 ;
     266EL119 ; Examine every rule that involves Element #119 [CLOZAPINE WBC < 3.0]
     267 ;  Called from SCAN+9^OCXOZ01.
     268 ;
     269 Q:$G(OCXOERR)
     270 ;
     271 D R57R1A^OCXOZ0W   ; Check Relation #1 in Rule #57 'CLOZAPINE'
     272 Q
     273 ;
     274EL118 ; Examine every rule that involves Element #118 [CLOZAPINE NO WBC W/IN 7 DAYS]
     275 ;  Called from SCAN+9^OCXOZ01.
     276 ;
     277 Q:$G(OCXOERR)
     278 ;
     279 D R57R2A^OCXOZ0W   ; Check Relation #2 in Rule #57 'CLOZAPINE'
     280 Q
     281 ;
     282EL117 ; Examine every rule that involves Element #117 [CLOZAPINE NO ANC W/IN 7 DAYS]
     283 ;  Called from SCAN+9^OCXOZ01.
     284 ;
     285 Q:$G(OCXOERR)
     286 ;
     287 D R57R3A^OCXOZ0W   ; Check Relation #3 in Rule #57 'CLOZAPINE'
     288 Q
     289 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m

    r613 r623  
    1 OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 EL114   ; Examine every rule that involves Element #114 [CLOZAPINE ANC < 1.5]
    14         ;  Called from SCAN+9^OCXOZ01.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         D R57R2A^OCXOZ0W   ; Check Relation #2 in Rule #57 'CLOZAPINE'
    19         Q
    20         ;
    21 EL119   ; Examine every rule that involves Element #119 [CLOZAPINE WBC < 3.0]
    22         ;  Called from SCAN+9^OCXOZ01.
    23         ;
    24         Q:$G(OCXOERR)
    25         ;
    26         D R57R2A^OCXOZ0W   ; Check Relation #2 in Rule #57 'CLOZAPINE'
    27         Q
    28         ;
    29 EL115   ; Examine every rule that involves Element #115 [CLOZAPINE ANC >= 1.5]
    30         ;  Called from SCAN+9^OCXOZ01.
    31         ;
    32         Q:$G(OCXOERR)
    33         ;
    34         D R57R3A^OCXOZ0W   ; Check Relation #3 in Rule #57 'CLOZAPINE'
    35         Q
    36         ;
    37 EL120   ; Examine every rule that involves Element #120 [CLOZAPINE WBC >= 3.0 & < 3.5]
    38         ;  Called from SCAN+9^OCXOZ01.
    39         ;
    40         Q:$G(OCXOERR)
    41         ;
    42         D R57R3A^OCXOZ0W   ; Check Relation #3 in Rule #57 'CLOZAPINE'
    43         Q
    44         ;
    45 EL140   ; Examine every rule that involves Element #140 [CLOZAPINE ANC >= 1.5 & < 2.0]
    46         ;  Called from SCAN+9^OCXOZ01.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         D R57R4A^OCXOZ0W   ; Check Relation #4 in Rule #57 'CLOZAPINE'
    51         Q
    52         ;
    53 EL71    ; Examine every rule that involves Element #71 [AMINOGLYCOSIDE ORDER SESSION]
    54         ;  Called from SCAN+9^OCXOZ01.
    55         ;
    56         Q:$G(OCXOERR)
    57         ;
    58         D R59R1A^OCXOZ0X   ; Check Relation #1 in Rule #59 'AMINOGLYCOSIDE ORDER'
    59         Q
    60         ;
    61 EL72    ; Examine every rule that involves Element #72 [PATIENT OVER CT OR MRI DEVICE LIMITATIONS]
    62         ;  Called from SCAN+9^OCXOZ01.
    63         ;
    64         Q:$G(OCXOERR)
    65         ;
    66         D R60R1A^OCXOZ0X   ; Check Relation #1 in Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK'
    67         Q
    68         ;
    69 EL73    ; Examine every rule that involves Element #73 [CREATININE CLEARANCE ESTIMATE]
    70         ;  Called from SCAN+9^OCXOZ01.
    71         ;
    72         Q:$G(OCXOERR)
    73         ;
    74         D R61R1A^OCXOZ0Y   ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION'
    75         Q
    76         ;
    77 EL96    ; Examine every rule that involves Element #96 [CREATININE CLEARANCE DATE/TIME]
    78         ;  Called from SCAN+9^OCXOZ01.
    79         ;
    80         Q:$G(OCXOERR)
    81         ;
    82         D R61R1A^OCXOZ0Y   ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION'
    83         Q
    84         ;
    85 EL97    ; Examine every rule that involves Element #97 [RENAL RESULTS]
    86         ;  Called from SCAN+9^OCXOZ01.
    87         ;
    88         Q:$G(OCXOERR)
    89         ;
    90         D R61R1A^OCXOZ0Y   ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION'
    91         Q
    92         ;
    93 EL84    ; Examine every rule that involves Element #84 [INPATIENT FOOD-DRUG REACTION]
    94         ;  Called from SCAN+9^OCXOZ01.
    95         ;
    96         Q:$G(OCXOERR)
    97         ;
    98         D R62R1A^OCXOZ0Z   ; Check Relation #1 in Rule #62 'FOOD/DRUG INTERACTION'
    99         Q
    100         ;
    101 EL91    ; Examine every rule that involves Element #91 [PATIENT WITH GLUCOPHAGE MED]
    102         ;  Called from SCAN+9^OCXOZ01.
    103         ;
    104         Q:$G(OCXOERR)
    105         ;
    106         D R63R1A^OCXOZ0Z   ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'
    107         Q
    108         ;
    109 EL106   ; Examine every rule that involves Element #106 [RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA]
    110         ;  Called from SCAN+9^OCXOZ01.
    111         ;
    112         Q:$G(OCXOERR)
    113         ;
    114         D R63R1A^OCXOZ0Z   ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'
    115         Q
    116         ;
    117 EL95    ; Examine every rule that involves Element #95 [POLYPHARMACY]
    118         ;  Called from SCAN+9^OCXOZ01.
    119         ;
    120         Q:$G(OCXOERR)
    121         ;
    122         D R65R1A^OCXOZ0Z   ; Check Relation #1 in Rule #65 'POLYPHARMACY'
    123         Q
    124         ;
    125 EL86    ; Examine every rule that involves Element #86 [GLUCOPHAGE ORDER]
    126         ;  Called from SCAN+9^OCXOZ01.
    127         ;
    128         Q:$G(OCXOERR)
    129         ;
    130         D R67R1A^OCXOZ10   ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
    131         D R67R2A^OCXOZ10   ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
    132         Q
    133         ;
    134 EL111   ; Examine every rule that involves Element #111 [GLUCOPHAGE CREATININE > 1.5]
    135         ;  Called from SCAN+9^OCXOZ01.
    136         ;
    137         Q:$G(OCXOERR)
    138         ;
    139         D R67R1A^OCXOZ10   ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
    140         Q
    141         ;
    142 EL112   ; Examine every rule that involves Element #112 [NO GLUCOPHAGE CREATININE]
    143         ;  Called from SCAN+9^OCXOZ01.
    144         ;
    145         Q:$G(OCXOERR)
    146         ;
    147         D R67R2A^OCXOZ10   ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
    148         Q
    149         ;
    150 EL122   ; Examine every rule that involves Element #122 [AMITRIPTYLINE ORDER]
    151         ;  Called from SCAN+9^OCXOZ01.
    152         ;
    153         Q:$G(OCXOERR)
    154         ;
    155         D R68R1A^OCXOZ11   ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
    156         Q
    157         ;
    158 EL125   ; Examine every rule that involves Element #125 [MED ORDER FOR PT > 64]
    159         ;  Called from SCAN+9^OCXOZ01.
    160         ;
    161         Q:$G(OCXOERR)
    162         ;
    163         D R68R1A^OCXOZ11   ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
    164         D R68R2A^OCXOZ11   ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
    165         D R68R3A^OCXOZ11   ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
    166         Q
    167         ;
    168 EL123   ; Examine every rule that involves Element #123 [CHLORPROPAMIDE ORDER]
    169         ;  Called from SCAN+9^OCXOZ01.
    170         ;
    171         Q:$G(OCXOERR)
    172         ;
    173         D R68R2A^OCXOZ11   ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
    174         Q
    175         ;
    176 EL124   ; Examine every rule that involves Element #124 [DIPYRIDAMOLE ORDER]
    177         ;  Called from SCAN+9^OCXOZ01.
    178         ;
    179         Q:$G(OCXOERR)
    180         ;
    181         D R68R3A^OCXOZ11   ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
    182         Q
    183         ;
    184 EL131   ; Examine every rule that involves Element #131 [GREATER THAN LAB THRESHOLD]
    185         ;  Called from SCAN+9^OCXOZ01.
    186         ;
    187         Q:$G(OCXOERR)
    188         ;
    189         D R69R1A^OCXOZ11   ; Check Relation #1 in Rule #69 'LAB THRESHOLD'
    190         Q
    191         ;
    192 EL132   ; Examine every rule that involves Element #132 [LESS THAN LAB THRESHOLD]
    193         ;  Called from SCAN+9^OCXOZ01.
    194         ;
    195         Q:$G(OCXOERR)
    196         ;
    197         D R69R1A^OCXOZ11   ; Check Relation #1 in Rule #69 'LAB THRESHOLD'
    198         Q
    199         ;
    200 EL28    ; Examine every rule that involves Element #28 [RADIOLOGY ORDER]
    201         ;  Called from SCAN+9^OCXOZ01.
    202         ;
    203         Q:$G(OCXOERR)
    204         ;
    205         D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
    206         Q
    207         ;
    208 EL135   ; Examine every rule that involves Element #135 [DIET ORDER]
    209         ;  Called from SCAN+9^OCXOZ01.
    210         ;
    211         Q:$G(OCXOERR)
    212         ;
    213         D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
    214         Q
    215         ;
    216 EL136   ; Examine every rule that involves Element #136 [NO ALLERGY ASSESSMENT]
    217         ;  Called from SCAN+9^OCXOZ01.
    218         ;
    219         Q:$G(OCXOERR)
    220         ;
    221         D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
    222         Q
    223         ;
    224 EL137   ; Examine every rule that involves Element #137 [PHARMACY ORDER]
    225         ;  Called from SCAN+9^OCXOZ01.
    226         ;
    227         Q:$G(OCXOERR)
    228         ;
    229         D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
    230         Q
    231         ;
    232 EL138   ; Examine every rule that involves Element #138 [DUP OPIOID MEDS]
    233         ;  Called from SCAN+9^OCXOZ01.
    234         ;
    235         Q:$G(OCXOERR)
    236         ;
    237         D R71R1A^OCXOZ13   ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS'
    238         Q
    239         ;
    240 EL139   ; Examine every rule that involves Element #139 [OPIOID MED ORDER]
    241         ;  Called from SCAN+9^OCXOZ01.
    242         ;
    243         Q:$G(OCXOERR)
    244         ;
    245         D R71R1A^OCXOZ13   ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS'
    246         Q
    247         ;
    248 R3R1A   ; Verify all Event/Elements of  Rule #3 'CRITICAL LAB RESULTS'  Relation #1 'CRITICAL LAB TEST'
    249         ;  Called from EL24+5^OCXOZ0G.
    250         ;
    251         Q:$G(OCXOERR)
    252         ;
    253         ;      Local Extrinsic Functions
    254         ; MCE24( ----------->  Verify Event/Element: 'HL7 LAB TEST RESULTS CRITICAL'
    255         ;
    256         Q:$G(^OCXS(860.2,3,"INACT"))
    257         ;
    258         I $$MCE24 D R3R1B^OCXOZ0J
    259         Q
    260         ;
    261 MCE24() ; Verify Event/Element: HL7 LAB TEST RESULTS CRITICAL
    262         ;
    263         ;
    264         N OCXRES
    265         I $L(OCXDF(37)) S OCXRES(24,37)=OCXDF(37)
    266         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),24)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),24))
    267         Q 0
    268         ;
     1OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13EL120 ; Examine every rule that involves Element #120 [CLOZAPINE WBC >= 3.0 & < 3.5]
     14 ;  Called from SCAN+9^OCXOZ01.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 D R57R3A^OCXOZ0W   ; Check Relation #3 in Rule #57 'CLOZAPINE'
     19 D R57R4A^OCXOZ0W   ; Check Relation #4 in Rule #57 'CLOZAPINE'
     20 Q
     21 ;
     22EL115 ; Examine every rule that involves Element #115 [CLOZAPINE ANC >= 1.5]
     23 ;  Called from SCAN+9^OCXOZ01.
     24 ;
     25 Q:$G(OCXOERR)
     26 ;
     27 D R57R4A^OCXOZ0W   ; Check Relation #4 in Rule #57 'CLOZAPINE'
     28 Q
     29 ;
     30EL121 ; Examine every rule that involves Element #121 [CLOZAPINE WBC >= 3.5]
     31 ;  Called from SCAN+9^OCXOZ01.
     32 ;
     33 Q:$G(OCXOERR)
     34 ;
     35 D R57R5A^OCXOZ0X   ; Check Relation #5 in Rule #57 'CLOZAPINE'
     36 Q
     37 ;
     38EL71 ; Examine every rule that involves Element #71 [AMINOGLYCOSIDE ORDER SESSION]
     39 ;  Called from SCAN+9^OCXOZ01.
     40 ;
     41 Q:$G(OCXOERR)
     42 ;
     43 D R59R1A^OCXOZ0X   ; Check Relation #1 in Rule #59 'AMINOGLYCOSIDE ORDER'
     44 Q
     45 ;
     46EL72 ; Examine every rule that involves Element #72 [PATIENT OVER CT OR MRI DEVICE LIMITATIONS]
     47 ;  Called from SCAN+9^OCXOZ01.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 D R60R1A^OCXOZ0X   ; Check Relation #1 in Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK'
     52 Q
     53 ;
     54EL73 ; Examine every rule that involves Element #73 [CREATININE CLEARANCE ESTIMATE]
     55 ;  Called from SCAN+9^OCXOZ01.
     56 ;
     57 Q:$G(OCXOERR)
     58 ;
     59 D R61R1A^OCXOZ0Y   ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION'
     60 Q
     61 ;
     62EL96 ; Examine every rule that involves Element #96 [CREATININE CLEARANCE DATE/TIME]
     63 ;  Called from SCAN+9^OCXOZ01.
     64 ;
     65 Q:$G(OCXOERR)
     66 ;
     67 D R61R1A^OCXOZ0Y   ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION'
     68 Q
     69 ;
     70EL97 ; Examine every rule that involves Element #97 [RENAL RESULTS]
     71 ;  Called from SCAN+9^OCXOZ01.
     72 ;
     73 Q:$G(OCXOERR)
     74 ;
     75 D R61R1A^OCXOZ0Y   ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION'
     76 Q
     77 ;
     78EL84 ; Examine every rule that involves Element #84 [INPATIENT FOOD-DRUG REACTION]
     79 ;  Called from SCAN+9^OCXOZ01.
     80 ;
     81 Q:$G(OCXOERR)
     82 ;
     83 D R62R1A^OCXOZ0Z   ; Check Relation #1 in Rule #62 'FOOD/DRUG INTERACTION'
     84 Q
     85 ;
     86EL91 ; Examine every rule that involves Element #91 [PATIENT WITH GLUCOPHAGE MED]
     87 ;  Called from SCAN+9^OCXOZ01.
     88 ;
     89 Q:$G(OCXOERR)
     90 ;
     91 D R63R1A^OCXOZ0Z   ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'
     92 Q
     93 ;
     94EL106 ; Examine every rule that involves Element #106 [RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA]
     95 ;  Called from SCAN+9^OCXOZ01.
     96 ;
     97 Q:$G(OCXOERR)
     98 ;
     99 D R63R1A^OCXOZ0Z   ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'
     100 Q
     101 ;
     102EL95 ; Examine every rule that involves Element #95 [POLYPHARMACY]
     103 ;  Called from SCAN+9^OCXOZ01.
     104 ;
     105 Q:$G(OCXOERR)
     106 ;
     107 D R65R1A^OCXOZ0Z   ; Check Relation #1 in Rule #65 'POLYPHARMACY'
     108 Q
     109 ;
     110EL86 ; Examine every rule that involves Element #86 [GLUCOPHAGE ORDER]
     111 ;  Called from SCAN+9^OCXOZ01.
     112 ;
     113 Q:$G(OCXOERR)
     114 ;
     115 D R67R1A^OCXOZ10   ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
     116 D R67R2A^OCXOZ10   ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
     117 Q
     118 ;
     119EL111 ; Examine every rule that involves Element #111 [GLUCOPHAGE CREATININE > 1.5]
     120 ;  Called from SCAN+9^OCXOZ01.
     121 ;
     122 Q:$G(OCXOERR)
     123 ;
     124 D R67R1A^OCXOZ10   ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
     125 Q
     126 ;
     127EL112 ; Examine every rule that involves Element #112 [NO GLUCOPHAGE CREATININE]
     128 ;  Called from SCAN+9^OCXOZ01.
     129 ;
     130 Q:$G(OCXOERR)
     131 ;
     132 D R67R2A^OCXOZ10   ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS'
     133 Q
     134 ;
     135EL122 ; Examine every rule that involves Element #122 [AMITRIPTYLINE ORDER]
     136 ;  Called from SCAN+9^OCXOZ01.
     137 ;
     138 Q:$G(OCXOERR)
     139 ;
     140 D R68R1A^OCXOZ11   ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
     141 Q
     142 ;
     143EL125 ; Examine every rule that involves Element #125 [MED ORDER FOR PT > 64]
     144 ;  Called from SCAN+9^OCXOZ01.
     145 ;
     146 Q:$G(OCXOERR)
     147 ;
     148 D R68R1A^OCXOZ11   ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
     149 D R68R2A^OCXOZ11   ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
     150 D R68R3A^OCXOZ11   ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
     151 Q
     152 ;
     153EL123 ; Examine every rule that involves Element #123 [CHLORPROPAMIDE ORDER]
     154 ;  Called from SCAN+9^OCXOZ01.
     155 ;
     156 Q:$G(OCXOERR)
     157 ;
     158 D R68R2A^OCXOZ11   ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
     159 Q
     160 ;
     161EL124 ; Examine every rule that involves Element #124 [DIPYRIDAMOLE ORDER]
     162 ;  Called from SCAN+9^OCXOZ01.
     163 ;
     164 Q:$G(OCXOERR)
     165 ;
     166 D R68R3A^OCXOZ11   ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64'
     167 Q
     168 ;
     169EL131 ; Examine every rule that involves Element #131 [GREATER THAN LAB THRESHOLD]
     170 ;  Called from SCAN+9^OCXOZ01.
     171 ;
     172 Q:$G(OCXOERR)
     173 ;
     174 D R69R1A^OCXOZ11   ; Check Relation #1 in Rule #69 'LAB THRESHOLD'
     175 Q
     176 ;
     177EL132 ; Examine every rule that involves Element #132 [LESS THAN LAB THRESHOLD]
     178 ;  Called from SCAN+9^OCXOZ01.
     179 ;
     180 Q:$G(OCXOERR)
     181 ;
     182 D R69R1A^OCXOZ11   ; Check Relation #1 in Rule #69 'LAB THRESHOLD'
     183 Q
     184 ;
     185EL28 ; Examine every rule that involves Element #28 [RADIOLOGY ORDER]
     186 ;  Called from SCAN+9^OCXOZ01.
     187 ;
     188 Q:$G(OCXOERR)
     189 ;
     190 D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
     191 Q
     192 ;
     193EL135 ; Examine every rule that involves Element #135 [DIET ORDER]
     194 ;  Called from SCAN+9^OCXOZ01.
     195 ;
     196 Q:$G(OCXOERR)
     197 ;
     198 D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
     199 Q
     200 ;
     201EL136 ; Examine every rule that involves Element #136 [NO ALLERGY ASSESSMENT]
     202 ;  Called from SCAN+9^OCXOZ01.
     203 ;
     204 Q:$G(OCXOERR)
     205 ;
     206 D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
     207 Q
     208 ;
     209EL137 ; Examine every rule that involves Element #137 [PHARMACY ORDER]
     210 ;  Called from SCAN+9^OCXOZ01.
     211 ;
     212 Q:$G(OCXOERR)
     213 ;
     214 D R70R1A^OCXOZ12   ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT'
     215 Q
     216 ;
     217EL138 ; Examine every rule that involves Element #138 [DUP OPIOID MEDS]
     218 ;  Called from SCAN+9^OCXOZ01.
     219 ;
     220 Q:$G(OCXOERR)
     221 ;
     222 D R71R1A^OCXOZ13   ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS'
     223 Q
     224 ;
     225EL139 ; Examine every rule that involves Element #139 [OPIOID MED ORDER]
     226 ;  Called from SCAN+9^OCXOZ01.
     227 ;
     228 Q:$G(OCXOERR)
     229 ;
     230 D R71R1A^OCXOZ13   ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS'
     231 Q
     232 ;
     233R3R1A ; Verify all Event/Elements of  Rule #3 'CRITICAL LAB RESULTS'  Relation #1 'CRITICAL LAB TEST'
     234 ;  Called from EL24+5^OCXOZ0G.
     235 ;
     236 Q:$G(OCXOERR)
     237 ;
     238 ;      Local Extrinsic Functions
     239 ; MCE24( ----------->  Verify Event/Element: 'HL7 LAB TEST RESULTS CRITICAL'
     240 ;
     241 Q:$G(^OCXS(860.2,3,"INACT"))
     242 ;
     243 I $$MCE24 D R3R1B^OCXOZ0J
     244 Q
     245 ;
     246MCE24() ; Verify Event/Element: HL7 LAB TEST RESULTS CRITICAL
     247 ;
     248 ;
     249 N OCXRES
     250 I $L(OCXDF(37)) S OCXRES(24,37)=OCXDF(37)
     251 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),24)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),24))
     252 Q 0
     253 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m

    r613 r623  
    1 OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R3R1B   ; Send Order Check, Notication messages and/or Execute code for  Rule #3 'CRITICAL LAB RESULTS'  Relation #1 'CRITICAL LAB TEST'
    14         ;  Called from R3R1A+10^OCXOZ0I.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    21         ; NEWRULE( ---------> NEW RULE MESSAGE
    22         ;
    23         Q:$D(OCXRULE("R3R1B"))
    24         ;
    25         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    26         S OCXCMSG=""
    27         S OCXNMSG="Critical lab: "_$$GETDATA(DFN,"24^",114)_" "_$$GETDATA(DFN,"24^",12)_" "_$$INT2DT($$GETDATA(DFN,"24^",13),0)
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ; Send Notification
    32         ;
    33         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    34         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    35         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    36         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    37         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    38         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    39         .S OCXNUM=+$P(OCXORD,U,2)
    40         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    41         S OCXRULE("R3R1B")=""
    42         I $$NEWRULE(DFN,OCXNUM,3,1,24,OCXNMSG) D  I 1
    43         .D:($G(OCXTRACE)<5) EN^ORB3(24,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    44         Q
    45         ;
    46 R3R2A   ; Verify all Event/Elements of  Rule #3 'CRITICAL LAB RESULTS'  Relation #2 'CRITICAL LAB ORDER'
    47         ;  Called from EL105+5^OCXOZ0G.
    48         ;
    49         Q:$G(OCXOERR)
    50         ;
    51         ;      Local Extrinsic Functions
    52         ; MCE105( ---------->  Verify Event/Element: 'HL7 LAB ORDER RESULTS CRITICAL'
    53         ;
    54         Q:$G(^OCXS(860.2,3,"INACT"))
    55         ;
    56         I $$MCE105 D R3R2B
    57         Q
    58         ;
    59 R3R2B   ; Send Order Check, Notication messages and/or Execute code for  Rule #3 'CRITICAL LAB RESULTS'  Relation #2 'CRITICAL LAB ORDER'
    60         ;  Called from R3R2A+10.
    61         ;
    62         Q:$G(OCXOERR)
    63         ;
    64         ;      Local Extrinsic Functions
    65         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    66         ; NEWRULE( ---------> NEW RULE MESSAGE
    67         ;
    68         Q:$D(OCXRULE("R3R2B"))
    69         ;
    70         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    71         S OCXCMSG=""
    72         S OCXNMSG="Critical labs - ["_$$GETDATA(DFN,"105^",96)_"]"
    73         ;
    74         Q:$G(OCXOERR)
    75         ;
    76         ; Send Notification
    77         ;
    78         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    79         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    80         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    81         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    82         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    83         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    84         .S OCXNUM=+$P(OCXORD,U,2)
    85         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    86         S OCXRULE("R3R2B")=""
    87         I $$NEWRULE(DFN,OCXNUM,3,2,57,OCXNMSG) D  I 1
    88         .D:($G(OCXTRACE)<5) EN^ORB3(57,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    89         Q
    90         ;
    91 R5R1A   ; Verify all Event/Elements of  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #1 'ORDER FLAGGED'
    92         ;  Called from EL44+5^OCXOZ0G.
    93         ;
    94         Q:$G(OCXOERR)
    95         ;
    96         ;      Local Extrinsic Functions
    97         ; MCE44( ----------->  Verify Event/Element: 'ORDER FLAGGED'
    98         ;
    99         Q:$G(^OCXS(860.2,5,"INACT"))
    100         ;
    101         I $$MCE44 D R5R1B^OCXOZ0K
    102         Q
    103         ;
    104 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    105         ;
    106         N CKSUM,PTR,ASC S CKSUM=0
    107         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    108         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    109         Q +CKSUM
    110         ;
    111 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    112         ;
    113         N OCXE,VAL,PC S VAL=""
    114         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    115         Q VAL
    116         ;
    117 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    118         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    119         ;
    120         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    121         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    122         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    123         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    124         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    125         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    126         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    127         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    128         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    129         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    130         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    131         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    132         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    133         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    134         E  S OCXMON=$E(OCXMON+100,2,3)
    135         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    136         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    137         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    138         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    139         Q OCXMON_" "_OCXDAY_","_OCXYR
    140         ;
    141 MCE105()        ; Verify Event/Element: HL7 LAB ORDER RESULTS CRITICAL
    142         ;
    143         ;
    144         N OCXRES
    145         I $L(OCXDF(37)) S OCXRES(105,37)=OCXDF(37)
    146         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),105)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),105))
    147         Q 0
    148         ;
    149 MCE44() ; Verify Event/Element: ORDER FLAGGED
    150         ;
    151         ;  OCXDF(37) -> PATIENT IEN data field
    152         ;
    153         N OCXRES
    154         S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(44,37)=OCXDF(37)
    155         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),44)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),44))
    156         Q 0
    157         ;
    158 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    159         ;
    160         ;
    161         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    162         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    163         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    164         ;
    165         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    166         ;
    167         S OCXTIME=(+$H)
    168         S OCXCKSUM=$$CKSUM(OCXMESS)
    169         ;
    170         S OCXTSP=($H*86400)+$P($H,",",2)
    171         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    172         ;
    173         Q:(OCXTSPL>OCXTSP) 0
    174         ;
    175         K OCXDATA
    176         S OCXDATA(OCXDFN,0)=OCXDFN
    177         S OCXDATA("B",OCXDFN,OCXDFN)=""
    178         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    179         ;
    180         S OCXGR="^OCXD(860.7"
    181         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    182         ;
    183         K OCXDATA
    184         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    185         S OCXDATA(OCXRUL,"M")=OCXMESS
    186         S OCXDATA("B",OCXRUL,OCXRUL)=""
    187         S OCXGR=OCXGR_","_OCXDFN_",1"
    188         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    189         ;
    190         K OCXDATA
    191         S OCXDATA(OCXREL,0)=OCXREL
    192         S OCXDATA("B",OCXREL,OCXREL)=""
    193         S OCXGR=OCXGR_","_OCXRUL_",1"
    194         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    195         ;
    196         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    197         .;
    198         .N OCXGR1
    199         .S OCXGR1=OCXGR_","_OCXREL_",1"
    200         .K OCXDATA
    201         .S OCXDATA(OCXELE,0)=OCXELE
    202         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    203         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    204         .S OCXDATA("B",OCXELE,OCXELE)=""
    205         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    206         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    207         .;
    208         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    209         ..N OCXGR2
    210         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    211         ..K OCXDATA
    212         ..S OCXDATA(OCXDFI,0)=OCXDFI
    213         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    214         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    215         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    216         ;
    217         Q 1
    218         ;
    219 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    220         M @ROOT=DATA
    221         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    222         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    223         ;
    224         Q
    225         ;
    226         ;
     1OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R3R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #3 'CRITICAL LAB RESULTS'  Relation #1 'CRITICAL LAB TEST'
     14 ;  Called from R3R1A+10^OCXOZ0I.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     21 ; NEWRULE( ---------> NEW RULE MESSAGE
     22 ;
     23 Q:$D(OCXRULE("R3R1B"))
     24 ;
     25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     26 S OCXCMSG=""
     27 S OCXNMSG="Critical lab: "_$$GETDATA(DFN,"24^",114)_" "_$$GETDATA(DFN,"24^",12)_" "_$$INT2DT($$GETDATA(DFN,"24^",13),0)
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ; Send Notification
     32 ;
     33 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     39 .S OCXNUM=+$P(OCXORD,U,2)
     40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     41 S OCXRULE("R3R1B")=""
     42 I $$NEWRULE(DFN,OCXNUM,3,1,24,OCXNMSG) D  I 1
     43 .D:($G(OCXTRACE)<5) EN^ORB3(24,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     44 Q
     45 ;
     46R3R2A ; Verify all Event/Elements of  Rule #3 'CRITICAL LAB RESULTS'  Relation #2 'CRITICAL LAB ORDER'
     47 ;  Called from EL105+5^OCXOZ0G.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 ;      Local Extrinsic Functions
     52 ; MCE105( ---------->  Verify Event/Element: 'HL7 LAB ORDER RESULTS CRITICAL'
     53 ;
     54 Q:$G(^OCXS(860.2,3,"INACT"))
     55 ;
     56 I $$MCE105 D R3R2B
     57 Q
     58 ;
     59R3R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #3 'CRITICAL LAB RESULTS'  Relation #2 'CRITICAL LAB ORDER'
     60 ;  Called from R3R2A+10.
     61 ;
     62 Q:$G(OCXOERR)
     63 ;
     64 ;      Local Extrinsic Functions
     65 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     66 ; NEWRULE( ---------> NEW RULE MESSAGE
     67 ;
     68 Q:$D(OCXRULE("R3R2B"))
     69 ;
     70 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     71 S OCXCMSG=""
     72 S OCXNMSG="Critical labs - ["_$$GETDATA(DFN,"105^",96)_"]"
     73 ;
     74 Q:$G(OCXOERR)
     75 ;
     76 ; Send Notification
     77 ;
     78 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     79 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     80 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     81 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     82 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     83 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     84 .S OCXNUM=+$P(OCXORD,U,2)
     85 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     86 S OCXRULE("R3R2B")=""
     87 I $$NEWRULE(DFN,OCXNUM,3,2,57,OCXNMSG) D  I 1
     88 .D:($G(OCXTRACE)<5) EN^ORB3(57,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     89 Q
     90 ;
     91R5R1A ; Verify all Event/Elements of  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #1 'ORDER FLAGGED'
     92 ;  Called from EL44+5^OCXOZ0G.
     93 ;
     94 Q:$G(OCXOERR)
     95 ;
     96 ;      Local Extrinsic Functions
     97 ; MCE44( ----------->  Verify Event/Element: 'ORDER FLAGGED'
     98 ;
     99 Q:$G(^OCXS(860.2,5,"INACT"))
     100 ;
     101 I $$MCE44 D R5R1B^OCXOZ0K
     102 Q
     103 ;
     104CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     105 ;
     106 N CKSUM,PTR,ASC S CKSUM=0
     107 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     108 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     109 Q +CKSUM
     110 ;
     111GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     112 ;
     113 N OCXE,VAL,PC S VAL=""
     114 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     115 Q VAL
     116 ;
     117INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     118 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     119 ;
     120 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     121 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     122 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     123 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     124 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     125 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     126 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     127 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     128 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     129 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     130 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     131 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     132 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     133 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     134 E  S OCXMON=$E(OCXMON+100,2,3)
     135 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     136 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     137 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     138 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     139 Q OCXMON_" "_OCXDAY_","_OCXYR
     140 ;
     141MCE105() ; Verify Event/Element: HL7 LAB ORDER RESULTS CRITICAL
     142 ;
     143 ;
     144 N OCXRES
     145 I $L(OCXDF(37)) S OCXRES(105,37)=OCXDF(37)
     146 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),105)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),105))
     147 Q 0
     148 ;
     149MCE44() ; Verify Event/Element: ORDER FLAGGED
     150 ;
     151 ;  OCXDF(37) -> PATIENT IEN data field
     152 ;
     153 N OCXRES
     154 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(44,37)=OCXDF(37)
     155 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),44)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),44))
     156 Q 0
     157 ;
     158NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     159 ;
     160 ;
     161 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     162 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     163 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     164 ;
     165 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     166 ;
     167 S OCXTIME=(+$H)
     168 S OCXCKSUM=$$CKSUM(OCXMESS)
     169 ;
     170 S OCXTSP=($H*86400)+$P($H,",",2)
     171 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     172 ;
     173 Q:(OCXTSPL>OCXTSP) 0
     174 ;
     175 K OCXDATA
     176 S OCXDATA(OCXDFN,0)=OCXDFN
     177 S OCXDATA("B",OCXDFN,OCXDFN)=""
     178 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     179 ;
     180 S OCXGR="^OCXD(860.7"
     181 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     182 ;
     183 K OCXDATA
     184 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     185 S OCXDATA(OCXRUL,"M")=OCXMESS
     186 S OCXDATA("B",OCXRUL,OCXRUL)=""
     187 S OCXGR=OCXGR_","_OCXDFN_",1"
     188 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     189 ;
     190 K OCXDATA
     191 S OCXDATA(OCXREL,0)=OCXREL
     192 S OCXDATA("B",OCXREL,OCXREL)=""
     193 S OCXGR=OCXGR_","_OCXRUL_",1"
     194 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     195 ;
     196 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     197 .;
     198 .N OCXGR1
     199 .S OCXGR1=OCXGR_","_OCXREL_",1"
     200 .K OCXDATA
     201 .S OCXDATA(OCXELE,0)=OCXELE
     202 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     203 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     204 .S OCXDATA("B",OCXELE,OCXELE)=""
     205 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     206 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     207 .;
     208 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     209 ..N OCXGR2
     210 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     211 ..K OCXDATA
     212 ..S OCXDATA(OCXDFI,0)=OCXDFI
     213 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     214 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     215 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     216 ;
     217 Q 1
     218 ;
     219SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     220 M @ROOT=DATA
     221 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     222 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     223 ;
     224 Q
     225 ;
     226 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m

    r613 r623  
    1 OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R5R1B   ; Send Order Check, Notication messages and/or Execute code for  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #1 'ORDER FLAGGED'
    14         ;  Called from R5R1A+10^OCXOZ0J.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; NEWRULE( ---------> NEW RULE MESSAGE
    21         ;
    22         Q:$D(OCXRULE("R5R1B"))
    23         ;
    24         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    25         S OCXCMSG=""
    26         S OCXNMSG="Order(s) needing clarification: Flagged "_$$GETDATA(DFN,"44^",115)_"."
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Notification
    31         ;
    32         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    33         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    34         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    35         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    36         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    37         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    38         .S OCXNUM=+$P(OCXORD,U,2)
    39         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    40         S OCXRULE("R5R1B")=""
    41         I $$NEWRULE(DFN,OCXNUM,5,1,6,OCXNMSG) D  I 1
    42         .D:($G(OCXTRACE)<5) EN^ORB3(6,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    43         Q
    44         ;
    45 R5R2A   ; Verify all Event/Elements of  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #2 'ORDER UNFLAGGED'
    46         ;  Called from EL134+5^OCXOZ0G.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ;      Local Extrinsic Functions
    51         ; MCE134( ---------->  Verify Event/Element: 'ORDER UNFLAGGED'
    52         ;
    53         Q:$G(^OCXS(860.2,5,"INACT"))
    54         ;
    55         I $$MCE134 D R5R2B
    56         Q
    57         ;
    58 R5R2B   ; Send Order Check, Notication messages and/or Execute code for  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #2 'ORDER UNFLAGGED'
    59         ;  Called from R5R2A+10.
    60         ;
    61         Q:$G(OCXOERR)
    62         ;
    63         ;      Local Extrinsic Functions
    64         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    65         ;
    66         Q:$D(OCXRULE("R5R2B"))
    67         ;
    68         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    69         S OCXCMSG=""
    70         S OCXNMSG=""
    71         ;
    72         ;
    73         ; Run Execute Code
    74         ;
    75         D UNFLAG^ORB3FUP1($$GETDATA(DFN,"134^",37))
    76         Q:$G(OCXOERR)
    77         Q
    78         ;
    79 R6R1A   ; Verify all Event/Elements of  Rule #6 'ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SIGNATURE'
    80         ;  Called from EL45+5^OCXOZ0G.
    81         ;
    82         Q:$G(OCXOERR)
    83         ;
    84         ;      Local Extrinsic Functions
    85         ; MCE45( ----------->  Verify Event/Element: 'ORDER REQUIRES CHART SIGNATURE'
    86         ;
    87         Q:$G(^OCXS(860.2,6,"INACT"))
    88         ;
    89         I $$MCE45 D R6R1B
    90         Q
    91         ;
    92 R6R1B   ; Send Order Check, Notication messages and/or Execute code for  Rule #6 'ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SIGNATURE'
    93         ;  Called from R6R1A+10.
    94         ;
    95         Q:$G(OCXOERR)
    96         ;
    97         ;      Local Extrinsic Functions
    98         ; NEWRULE( ---------> NEW RULE MESSAGE
    99         ;
    100         Q:$D(OCXRULE("R6R1B"))
    101         ;
    102         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    103         S OCXCMSG=""
    104         S OCXNMSG="Order released - requires chart signature."
    105         ;
    106         Q:$G(OCXOERR)
    107         ;
    108         ; Send Notification
    109         ;
    110         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    111         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    112         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    113         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    114         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    115         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    116         .S OCXNUM=+$P(OCXORD,U,2)
    117         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    118         S OCXRULE("R6R1B")=""
    119         I $$NEWRULE(DFN,OCXNUM,6,1,5,OCXNMSG) D  I 1
    120         .D:($G(OCXTRACE)<5) EN^ORB3(5,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    121         Q
    122         ;
    123 R7R1A   ; Verify all Event/Elements of  Rule #7 'PATIENT ADMISSION'  Relation #1 'ADMISSION'
    124         ;  Called from EL21+5^OCXOZ0G.
    125         ;
    126         Q:$G(OCXOERR)
    127         ;
    128         ;      Local Extrinsic Functions
    129         ; MCE21( ----------->  Verify Event/Element: 'PATIENT ADMISSION'
    130         ;
    131         Q:$G(^OCXS(860.2,7,"INACT"))
    132         ;
    133         I $$MCE21 D R7R1B^OCXOZ0L
    134         Q
    135         ;
    136 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    137         ;
    138         N CKSUM,PTR,ASC S CKSUM=0
    139         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    140         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    141         Q +CKSUM
    142         ;
    143 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    144         ;
    145         N OCXE,VAL,PC S VAL=""
    146         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    147         Q VAL
    148         ;
    149 MCE134()        ; Verify Event/Element: ORDER UNFLAGGED
    150         ;
    151         ;  OCXDF(37) -> PATIENT IEN data field
    152         ;
    153         N OCXRES
    154         S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(134,37)=OCXDF(37)
    155         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),134)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),134))
    156         Q 0
    157         ;
    158 MCE21() ; Verify Event/Element: PATIENT ADMISSION
    159         ;
    160         ;  OCXDF(37) -> PATIENT IEN data field
    161         ;
    162         N OCXRES
    163         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(21,37)=OCXDF(37)
    164         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),21)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),21))
    165         Q 0
    166         ;
    167 MCE45() ; Verify Event/Element: ORDER REQUIRES CHART SIGNATURE
    168         ;
    169         ;  OCXDF(37) -> PATIENT IEN data field
    170         ;
    171         N OCXRES
    172         S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(45,37)=OCXDF(37)
    173         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),45)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),45))
    174         Q 0
    175         ;
    176 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    177         ;
    178         ;
    179         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    180         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    181         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    182         ;
    183         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    184         ;
    185         S OCXTIME=(+$H)
    186         S OCXCKSUM=$$CKSUM(OCXMESS)
    187         ;
    188         S OCXTSP=($H*86400)+$P($H,",",2)
    189         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    190         ;
    191         Q:(OCXTSPL>OCXTSP) 0
    192         ;
    193         K OCXDATA
    194         S OCXDATA(OCXDFN,0)=OCXDFN
    195         S OCXDATA("B",OCXDFN,OCXDFN)=""
    196         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    197         ;
    198         S OCXGR="^OCXD(860.7"
    199         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    200         ;
    201         K OCXDATA
    202         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    203         S OCXDATA(OCXRUL,"M")=OCXMESS
    204         S OCXDATA("B",OCXRUL,OCXRUL)=""
    205         S OCXGR=OCXGR_","_OCXDFN_",1"
    206         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    207         ;
    208         K OCXDATA
    209         S OCXDATA(OCXREL,0)=OCXREL
    210         S OCXDATA("B",OCXREL,OCXREL)=""
    211         S OCXGR=OCXGR_","_OCXRUL_",1"
    212         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    213         ;
    214         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    215         .;
    216         .N OCXGR1
    217         .S OCXGR1=OCXGR_","_OCXREL_",1"
    218         .K OCXDATA
    219         .S OCXDATA(OCXELE,0)=OCXELE
    220         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    221         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    222         .S OCXDATA("B",OCXELE,OCXELE)=""
    223         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    224         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    225         .;
    226         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    227         ..N OCXGR2
    228         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    229         ..K OCXDATA
    230         ..S OCXDATA(OCXDFI,0)=OCXDFI
    231         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    232         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    233         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    234         ;
    235         Q 1
    236         ;
    237 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    238         M @ROOT=DATA
    239         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    240         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    241         ;
    242         Q
    243         ;
    244         ;
     1OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R5R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #1 'ORDER FLAGGED'
     14 ;  Called from R5R1A+10^OCXOZ0J.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; NEWRULE( ---------> NEW RULE MESSAGE
     21 ;
     22 Q:$D(OCXRULE("R5R1B"))
     23 ;
     24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     25 S OCXCMSG=""
     26 S OCXNMSG="Order(s) needing clarification: Flagged "_$$GETDATA(DFN,"44^",115)_"."
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Notification
     31 ;
     32 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     38 .S OCXNUM=+$P(OCXORD,U,2)
     39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     40 S OCXRULE("R5R1B")=""
     41 I $$NEWRULE(DFN,OCXNUM,5,1,6,OCXNMSG) D  I 1
     42 .D:($G(OCXTRACE)<5) EN^ORB3(6,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     43 Q
     44 ;
     45R5R2A ; Verify all Event/Elements of  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #2 'ORDER UNFLAGGED'
     46 ;  Called from EL134+5^OCXOZ0G.
     47 ;
     48 Q:$G(OCXOERR)
     49 ;
     50 ;      Local Extrinsic Functions
     51 ; MCE134( ---------->  Verify Event/Element: 'ORDER UNFLAGGED'
     52 ;
     53 Q:$G(^OCXS(860.2,5,"INACT"))
     54 ;
     55 I $$MCE134 D R5R2B
     56 Q
     57 ;
     58R5R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #5 'ORDER FLAGGED FOR CLARIFICATION'  Relation #2 'ORDER UNFLAGGED'
     59 ;  Called from R5R2A+10.
     60 ;
     61 Q:$G(OCXOERR)
     62 ;
     63 ;      Local Extrinsic Functions
     64 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     65 ;
     66 Q:$D(OCXRULE("R5R2B"))
     67 ;
     68 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     69 S OCXCMSG=""
     70 S OCXNMSG=""
     71 ;
     72 ;
     73 ; Run Execute Code
     74 ;
     75 D UNFLAG^ORB3FUP1($$GETDATA(DFN,"134^",37))
     76 Q:$G(OCXOERR)
     77 Q
     78 ;
     79R6R1A ; Verify all Event/Elements of  Rule #6 'ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SIGNATURE'
     80 ;  Called from EL45+5^OCXOZ0G.
     81 ;
     82 Q:$G(OCXOERR)
     83 ;
     84 ;      Local Extrinsic Functions
     85 ; MCE45( ----------->  Verify Event/Element: 'ORDER REQUIRES CHART SIGNATURE'
     86 ;
     87 Q:$G(^OCXS(860.2,6,"INACT"))
     88 ;
     89 I $$MCE45 D R6R1B
     90 Q
     91 ;
     92R6R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #6 'ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SIGNATURE'
     93 ;  Called from R6R1A+10.
     94 ;
     95 Q:$G(OCXOERR)
     96 ;
     97 ;      Local Extrinsic Functions
     98 ; NEWRULE( ---------> NEW RULE MESSAGE
     99 ;
     100 Q:$D(OCXRULE("R6R1B"))
     101 ;
     102 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     103 S OCXCMSG=""
     104 S OCXNMSG="Order released - requires chart signature."
     105 ;
     106 Q:$G(OCXOERR)
     107 ;
     108 ; Send Notification
     109 ;
     110 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     111 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     112 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     113 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     114 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     115 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     116 .S OCXNUM=+$P(OCXORD,U,2)
     117 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     118 S OCXRULE("R6R1B")=""
     119 I $$NEWRULE(DFN,OCXNUM,6,1,5,OCXNMSG) D  I 1
     120 .D:($G(OCXTRACE)<5) EN^ORB3(5,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     121 Q
     122 ;
     123R7R1A ; Verify all Event/Elements of  Rule #7 'PATIENT ADMISSION'  Relation #1 'ADMISSION'
     124 ;  Called from EL21+5^OCXOZ0G.
     125 ;
     126 Q:$G(OCXOERR)
     127 ;
     128 ;      Local Extrinsic Functions
     129 ; MCE21( ----------->  Verify Event/Element: 'PATIENT ADMISSION'
     130 ;
     131 Q:$G(^OCXS(860.2,7,"INACT"))
     132 ;
     133 I $$MCE21 D R7R1B^OCXOZ0L
     134 Q
     135 ;
     136CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     137 ;
     138 N CKSUM,PTR,ASC S CKSUM=0
     139 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     140 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     141 Q +CKSUM
     142 ;
     143GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     144 ;
     145 N OCXE,VAL,PC S VAL=""
     146 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     147 Q VAL
     148 ;
     149MCE134() ; Verify Event/Element: ORDER UNFLAGGED
     150 ;
     151 ;  OCXDF(37) -> PATIENT IEN data field
     152 ;
     153 N OCXRES
     154 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(134,37)=OCXDF(37)
     155 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),134)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),134))
     156 Q 0
     157 ;
     158MCE21() ; Verify Event/Element: PATIENT ADMISSION
     159 ;
     160 ;  OCXDF(37) -> PATIENT IEN data field
     161 ;
     162 N OCXRES
     163 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(21,37)=OCXDF(37)
     164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),21)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),21))
     165 Q 0
     166 ;
     167MCE45() ; Verify Event/Element: ORDER REQUIRES CHART SIGNATURE
     168 ;
     169 ;  OCXDF(37) -> PATIENT IEN data field
     170 ;
     171 N OCXRES
     172 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(45,37)=OCXDF(37)
     173 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),45)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),45))
     174 Q 0
     175 ;
     176NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     177 ;
     178 ;
     179 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     180 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     181 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     182 ;
     183 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     184 ;
     185 S OCXTIME=(+$H)
     186 S OCXCKSUM=$$CKSUM(OCXMESS)
     187 ;
     188 S OCXTSP=($H*86400)+$P($H,",",2)
     189 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     190 ;
     191 Q:(OCXTSPL>OCXTSP) 0
     192 ;
     193 K OCXDATA
     194 S OCXDATA(OCXDFN,0)=OCXDFN
     195 S OCXDATA("B",OCXDFN,OCXDFN)=""
     196 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     197 ;
     198 S OCXGR="^OCXD(860.7"
     199 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     200 ;
     201 K OCXDATA
     202 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     203 S OCXDATA(OCXRUL,"M")=OCXMESS
     204 S OCXDATA("B",OCXRUL,OCXRUL)=""
     205 S OCXGR=OCXGR_","_OCXDFN_",1"
     206 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     207 ;
     208 K OCXDATA
     209 S OCXDATA(OCXREL,0)=OCXREL
     210 S OCXDATA("B",OCXREL,OCXREL)=""
     211 S OCXGR=OCXGR_","_OCXRUL_",1"
     212 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     213 ;
     214 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     215 .;
     216 .N OCXGR1
     217 .S OCXGR1=OCXGR_","_OCXREL_",1"
     218 .K OCXDATA
     219 .S OCXDATA(OCXELE,0)=OCXELE
     220 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     221 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     222 .S OCXDATA("B",OCXELE,OCXELE)=""
     223 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     224 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     225 .;
     226 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     227 ..N OCXGR2
     228 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     229 ..K OCXDATA
     230 ..S OCXDATA(OCXDFI,0)=OCXDFI
     231 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     232 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     233 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     234 ;
     235 Q 1
     236 ;
     237SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     238 M @ROOT=DATA
     239 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     240 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     241 ;
     242 Q
     243 ;
     244 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m

    r613 r623  
    1 OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R7R1B   ; Send Order Check, Notication messages and/or Execute code for  Rule #7 'PATIENT ADMISSION'  Relation #1 'ADMISSION'
    14         ;  Called from R7R1A+10^OCXOZ0K.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    21         ; NEWRULE( ---------> NEW RULE MESSAGE
    22         ;
    23         Q:$D(OCXRULE("R7R1B"))
    24         ;
    25         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    26         S OCXCMSG=""
    27         S OCXNMSG="Admitted on "_$$INT2DT($$GETDATA(DFN,"21^",26),0)_" to "_$$GETDATA(DFN,"21^",83)
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ; Send Notification
    32         ;
    33         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    34         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    35         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    36         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    37         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    38         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    39         .S OCXNUM=+$P(OCXORD,U,2)
    40         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    41         S OCXRULE("R7R1B")=""
    42         I $$NEWRULE(DFN,OCXNUM,7,1,18,OCXNMSG) D  I 1
    43         .D:($G(OCXTRACE)<5) EN^ORB3(18,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    44         Q
    45         ;
    46 R11R1A  ; Verify all Event/Elements of  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER'
    47         ;  Called from EL31+5^OCXOZ0G, and EL100+5^OCXOZ0G.
    48         ;
    49         Q:$G(OCXOERR)
    50         ;
    51         ;      Local Extrinsic Functions
    52         ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
    53         ; MCE31( ----------->  Verify Event/Element: 'RADIOLOGY ORDER CANCELLED'
    54         ;
    55         Q:$G(^OCXS(860.2,11,"INACT"))
    56         ;
    57         I $$MCE31 D
    58         .I $$MCE100 D R11R1B
    59         Q
    60         ;
    61 R11R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER'
    62         ;  Called from R11R1A+12.
    63         ;
    64         Q:$G(OCXOERR)
    65         ;
    66         ;      Local Extrinsic Functions
    67         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    68         ; NEWRULE( ---------> NEW RULE MESSAGE
    69         ;
    70         Q:$D(OCXRULE("R11R1B"))
    71         ;
    72         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    73         S OCXCMSG=""
    74         S OCXNMSG="Imaging request canceled: "_$$GETDATA(DFN,"31^100",105)
    75         ;
    76         Q:$G(OCXOERR)
    77         ;
    78         ; Send Notification
    79         ;
    80         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    81         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    82         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    83         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    84         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    85         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    86         .S OCXNUM=+$P(OCXORD,U,2)
    87         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    88         S OCXRULE("R11R1B")=""
    89         I $$NEWRULE(DFN,OCXNUM,11,1,26,OCXNMSG) D  I 1
    90         .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    91         Q
    92         ;
    93 R11R2A  ; Verify all Event/Elements of  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER'
    94         ;  Called from EL100+6^OCXOZ0G, and EL30+5^OCXOZ0G.
    95         ;
    96         Q:$G(OCXOERR)
    97         ;
    98         ;      Local Extrinsic Functions
    99         ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
    100         ; MCE30( ----------->  Verify Event/Element: 'RADIOLOGY ORDER PUT ON-HOLD'
    101         ;
    102         Q:$G(^OCXS(860.2,11,"INACT"))
    103         ;
    104         I $$MCE30 D
    105         .I $$MCE100 D R11R2B^OCXOZ0M
    106         Q
    107         ;
    108 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    109         ;
    110         N CKSUM,PTR,ASC S CKSUM=0
    111         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    112         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    113         Q +CKSUM
    114         ;
    115 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    116         ;
    117         N OCXE,VAL,PC S VAL=""
    118         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    119         Q VAL
    120         ;
    121 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    122         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    123         ;
    124         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    125         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    126         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    127         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    128         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    129         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    130         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    131         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    132         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    133         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    134         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    135         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    136         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    137         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    138         E  S OCXMON=$E(OCXMON+100,2,3)
    139         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    140         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    141         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    142         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    143         Q OCXMON_" "_OCXDAY_","_OCXYR
    144         ;
    145 MCE100()        ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER
    146         ;
    147         ;
    148         N OCXRES
    149         I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37)
    150         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100))
    151         Q 0
    152         ;
    153 MCE30() ; Verify Event/Element: RADIOLOGY ORDER PUT ON-HOLD
    154         ;
    155         ;
    156         N OCXRES
    157         I $L(OCXDF(37)) S OCXRES(30,37)=OCXDF(37)
    158         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),30)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),30))
    159         Q 0
    160         ;
    161 MCE31() ; Verify Event/Element: RADIOLOGY ORDER CANCELLED
    162         ;
    163         ;
    164         N OCXRES
    165         I $L(OCXDF(37)) S OCXRES(31,37)=OCXDF(37)
    166         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),31)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),31))
    167         Q 0
    168         ;
    169 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    170         ;
    171         ;
    172         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    173         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    174         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    175         ;
    176         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    177         ;
    178         S OCXTIME=(+$H)
    179         S OCXCKSUM=$$CKSUM(OCXMESS)
    180         ;
    181         S OCXTSP=($H*86400)+$P($H,",",2)
    182         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    183         ;
    184         Q:(OCXTSPL>OCXTSP) 0
    185         ;
    186         K OCXDATA
    187         S OCXDATA(OCXDFN,0)=OCXDFN
    188         S OCXDATA("B",OCXDFN,OCXDFN)=""
    189         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    190         ;
    191         S OCXGR="^OCXD(860.7"
    192         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    193         ;
    194         K OCXDATA
    195         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    196         S OCXDATA(OCXRUL,"M")=OCXMESS
    197         S OCXDATA("B",OCXRUL,OCXRUL)=""
    198         S OCXGR=OCXGR_","_OCXDFN_",1"
    199         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    200         ;
    201         K OCXDATA
    202         S OCXDATA(OCXREL,0)=OCXREL
    203         S OCXDATA("B",OCXREL,OCXREL)=""
    204         S OCXGR=OCXGR_","_OCXRUL_",1"
    205         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    206         ;
    207         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    208         .;
    209         .N OCXGR1
    210         .S OCXGR1=OCXGR_","_OCXREL_",1"
    211         .K OCXDATA
    212         .S OCXDATA(OCXELE,0)=OCXELE
    213         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    214         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    215         .S OCXDATA("B",OCXELE,OCXELE)=""
    216         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    217         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    218         .;
    219         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    220         ..N OCXGR2
    221         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    222         ..K OCXDATA
    223         ..S OCXDATA(OCXDFI,0)=OCXDFI
    224         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    225         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    226         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    227         ;
    228         Q 1
    229         ;
    230 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    231         M @ROOT=DATA
    232         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    233         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    234         ;
    235         Q
    236         ;
    237         ;
     1OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R7R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #7 'PATIENT ADMISSION'  Relation #1 'ADMISSION'
     14 ;  Called from R7R1A+10^OCXOZ0K.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     21 ; NEWRULE( ---------> NEW RULE MESSAGE
     22 ;
     23 Q:$D(OCXRULE("R7R1B"))
     24 ;
     25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     26 S OCXCMSG=""
     27 S OCXNMSG="Admitted on "_$$INT2DT($$GETDATA(DFN,"21^",26),0)_" to "_$$GETDATA(DFN,"21^",83)
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ; Send Notification
     32 ;
     33 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     39 .S OCXNUM=+$P(OCXORD,U,2)
     40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     41 S OCXRULE("R7R1B")=""
     42 I $$NEWRULE(DFN,OCXNUM,7,1,18,OCXNMSG) D  I 1
     43 .D:($G(OCXTRACE)<5) EN^ORB3(18,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     44 Q
     45 ;
     46R11R1A ; Verify all Event/Elements of  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER'
     47 ;  Called from EL31+5^OCXOZ0G, and EL100+5^OCXOZ0G.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 ;      Local Extrinsic Functions
     52 ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
     53 ; MCE31( ----------->  Verify Event/Element: 'RADIOLOGY ORDER CANCELLED'
     54 ;
     55 Q:$G(^OCXS(860.2,11,"INACT"))
     56 ;
     57 I $$MCE31 D
     58 .I $$MCE100 D R11R1B
     59 Q
     60 ;
     61R11R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER'
     62 ;  Called from R11R1A+12.
     63 ;
     64 Q:$G(OCXOERR)
     65 ;
     66 ;      Local Extrinsic Functions
     67 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     68 ; NEWRULE( ---------> NEW RULE MESSAGE
     69 ;
     70 Q:$D(OCXRULE("R11R1B"))
     71 ;
     72 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     73 S OCXCMSG=""
     74 S OCXNMSG="Imaging request canceled: "_$$GETDATA(DFN,"31^100",105)
     75 ;
     76 Q:$G(OCXOERR)
     77 ;
     78 ; Send Notification
     79 ;
     80 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     81 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     82 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     83 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     84 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     85 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     86 .S OCXNUM=+$P(OCXORD,U,2)
     87 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     88 S OCXRULE("R11R1B")=""
     89 I $$NEWRULE(DFN,OCXNUM,11,1,26,OCXNMSG) D  I 1
     90 .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     91 Q
     92 ;
     93R11R2A ; Verify all Event/Elements of  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER'
     94 ;  Called from EL100+6^OCXOZ0G, and EL30+5^OCXOZ0G.
     95 ;
     96 Q:$G(OCXOERR)
     97 ;
     98 ;      Local Extrinsic Functions
     99 ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
     100 ; MCE30( ----------->  Verify Event/Element: 'RADIOLOGY ORDER PUT ON-HOLD'
     101 ;
     102 Q:$G(^OCXS(860.2,11,"INACT"))
     103 ;
     104 I $$MCE30 D
     105 .I $$MCE100 D R11R2B^OCXOZ0M
     106 Q
     107 ;
     108CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     109 ;
     110 N CKSUM,PTR,ASC S CKSUM=0
     111 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     112 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     113 Q +CKSUM
     114 ;
     115GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     116 ;
     117 N OCXE,VAL,PC S VAL=""
     118 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     119 Q VAL
     120 ;
     121INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     122 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     123 ;
     124 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     125 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     126 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     127 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     128 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     129 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     130 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     131 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     132 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     133 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     134 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     135 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     136 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     137 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     138 E  S OCXMON=$E(OCXMON+100,2,3)
     139 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     140 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     141 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     142 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     143 Q OCXMON_" "_OCXDAY_","_OCXYR
     144 ;
     145MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER
     146 ;
     147 ;
     148 N OCXRES
     149 I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37)
     150 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100))
     151 Q 0
     152 ;
     153MCE30() ; Verify Event/Element: RADIOLOGY ORDER PUT ON-HOLD
     154 ;
     155 ;
     156 N OCXRES
     157 I $L(OCXDF(37)) S OCXRES(30,37)=OCXDF(37)
     158 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),30)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),30))
     159 Q 0
     160 ;
     161MCE31() ; Verify Event/Element: RADIOLOGY ORDER CANCELLED
     162 ;
     163 ;
     164 N OCXRES
     165 I $L(OCXDF(37)) S OCXRES(31,37)=OCXDF(37)
     166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),31)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),31))
     167 Q 0
     168 ;
     169NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     170 ;
     171 ;
     172 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     173 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     174 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     175 ;
     176 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     177 ;
     178 S OCXTIME=(+$H)
     179 S OCXCKSUM=$$CKSUM(OCXMESS)
     180 ;
     181 S OCXTSP=($H*86400)+$P($H,",",2)
     182 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     183 ;
     184 Q:(OCXTSPL>OCXTSP) 0
     185 ;
     186 K OCXDATA
     187 S OCXDATA(OCXDFN,0)=OCXDFN
     188 S OCXDATA("B",OCXDFN,OCXDFN)=""
     189 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     190 ;
     191 S OCXGR="^OCXD(860.7"
     192 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     193 ;
     194 K OCXDATA
     195 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     196 S OCXDATA(OCXRUL,"M")=OCXMESS
     197 S OCXDATA("B",OCXRUL,OCXRUL)=""
     198 S OCXGR=OCXGR_","_OCXDFN_",1"
     199 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     200 ;
     201 K OCXDATA
     202 S OCXDATA(OCXREL,0)=OCXREL
     203 S OCXDATA("B",OCXREL,OCXREL)=""
     204 S OCXGR=OCXGR_","_OCXRUL_",1"
     205 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     206 ;
     207 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     208 .;
     209 .N OCXGR1
     210 .S OCXGR1=OCXGR_","_OCXREL_",1"
     211 .K OCXDATA
     212 .S OCXDATA(OCXELE,0)=OCXELE
     213 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     214 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     215 .S OCXDATA("B",OCXELE,OCXELE)=""
     216 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     217 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     218 .;
     219 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     220 ..N OCXGR2
     221 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     222 ..K OCXDATA
     223 ..S OCXDATA(OCXDFI,0)=OCXDFI
     224 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     225 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     226 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     227 ;
     228 Q 1
     229 ;
     230SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     231 M @ROOT=DATA
     232 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     233 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     234 ;
     235 Q
     236 ;
     237 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m

    r613 r623  
    1 OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R11R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER'
    14         ;  Called from R11R2A+12^OCXOZ0L.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; NEWRULE( ---------> NEW RULE MESSAGE
    21         ;
    22         Q:$D(OCXRULE("R11R2B"))
    23         ;
    24         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    25         S OCXCMSG=""
    26         S OCXNMSG="Imaging request held: "_$$GETDATA(DFN,"30^100",105)
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Notification
    31         ;
    32         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    33         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    34         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    35         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    36         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    37         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    38         .S OCXNUM=+$P(OCXORD,U,2)
    39         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    40         S OCXRULE("R11R2B")=""
    41         I $$NEWRULE(DFN,OCXNUM,11,2,26,OCXNMSG) D  I 1
    42         .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    43         Q
    44         ;
    45 R11R3A  ; Verify all Event/Elements of  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER'
    46         ;  Called from EL100+7^OCXOZ0G, and EL32+5^OCXOZ0G.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ;      Local Extrinsic Functions
    51         ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
    52         ; MCE32( ----------->  Verify Event/Element: 'RADIOLOGY ORDER DISCONTINUED'
    53         ;
    54         Q:$G(^OCXS(860.2,11,"INACT"))
    55         ;
    56         I $$MCE32 D
    57         .I $$MCE100 D R11R3B
    58         Q
    59         ;
    60 R11R3B  ; Send Order Check, Notication messages and/or Execute code for  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER'
    61         ;  Called from R11R3A+12.
    62         ;
    63         Q:$G(OCXOERR)
    64         ;
    65         ;      Local Extrinsic Functions
    66         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    67         ; NEWRULE( ---------> NEW RULE MESSAGE
    68         ;
    69         Q:$D(OCXRULE("R11R3B"))
    70         ;
    71         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    72         S OCXCMSG=""
    73         S OCXNMSG="Imaging request discontinued: "_$$GETDATA(DFN,"32^100",105)
    74         ;
    75         Q:$G(OCXOERR)
    76         ;
    77         ; Send Notification
    78         ;
    79         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    80         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    81         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    82         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    83         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    84         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    85         .S OCXNUM=+$P(OCXORD,U,2)
    86         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    87         S OCXRULE("R11R3B")=""
    88         I $$NEWRULE(DFN,OCXNUM,11,3,26,OCXNMSG) D  I 1
    89         .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    90         Q
    91         ;
    92 R16R1A  ; Verify all Event/Elements of  Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SERVICE'
    93         ;  Called from EL46+5^OCXOZ0G.
    94         ;
    95         Q:$G(OCXOERR)
    96         ;
    97         ;      Local Extrinsic Functions
    98         ; MCE46( ----------->  Verify Event/Element: 'SERVICE ORDER REQUIRES CHART SIGNATURE'
    99         ;
    100         Q:$G(^OCXS(860.2,16,"INACT"))
    101         ;
    102         I $$MCE46 D R16R1B
    103         Q
    104         ;
    105 R16R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SERVICE'
    106         ;  Called from R16R1A+10.
    107         ;
    108         Q:$G(OCXOERR)
    109         ;
    110         ;      Local Extrinsic Functions
    111         ; NEWRULE( ---------> NEW RULE MESSAGE
    112         ;
    113         Q:$D(OCXRULE("R16R1B"))
    114         ;
    115         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    116         S OCXCMSG=""
    117         S OCXNMSG="Service order - requires chart signature."
    118         ;
    119         Q:$G(OCXOERR)
    120         ;
    121         ; Send Notification
    122         ;
    123         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    124         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    125         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    126         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    127         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    128         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    129         .S OCXNUM=+$P(OCXORD,U,2)
    130         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    131         S OCXRULE("R16R1B")=""
    132         I $$NEWRULE(DFN,OCXNUM,16,1,28,OCXNMSG) D  I 1
    133         .D:($G(OCXTRACE)<5) EN^ORB3(28,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    134         Q
    135         ;
    136 R18R1A  ; Verify all Event/Elements of  Rule #18 'STAT RESULTS AVAILABLE'  Relation #1 'STAT LAB RESULT'
    137         ;  Called from EL76+5^OCXOZ0G.
    138         ;
    139         Q:$G(OCXOERR)
    140         ;
    141         ;      Local Extrinsic Functions
    142         ; MCE76( ----------->  Verify Event/Element: 'STAT LAB RESULT'
    143         ;
    144         Q:$G(^OCXS(860.2,18,"INACT"))
    145         ;
    146         I $$MCE76 D R18R1B^OCXOZ0N
    147         Q
    148         ;
    149 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    150         ;
    151         N CKSUM,PTR,ASC S CKSUM=0
    152         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    153         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    154         Q +CKSUM
    155         ;
    156 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    157         ;
    158         N OCXE,VAL,PC S VAL=""
    159         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    160         Q VAL
    161         ;
    162 MCE100()        ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER
    163         ;
    164         ;
    165         N OCXRES
    166         I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37)
    167         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100))
    168         Q 0
    169         ;
    170 MCE32() ; Verify Event/Element: RADIOLOGY ORDER DISCONTINUED
    171         ;
    172         ;
    173         N OCXRES
    174         I $L(OCXDF(37)) S OCXRES(32,37)=OCXDF(37)
    175         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),32)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),32))
    176         Q 0
    177         ;
    178 MCE46() ; Verify Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE
    179         ;
    180         ;  OCXDF(37) -> PATIENT IEN data field
    181         ;
    182         N OCXRES
    183         S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(46,37)=OCXDF(37)
    184         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),46)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),46))
    185         Q 0
    186         ;
    187 MCE76() ; Verify Event/Element: STAT LAB RESULT
    188         ;
    189         ;
    190         N OCXRES
    191         I $L(OCXDF(37)) S OCXRES(76,37)=OCXDF(37)
    192         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),76)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),76))
    193         Q 0
    194         ;
    195 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    196         ;
    197         ;
    198         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    199         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    200         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    201         ;
    202         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    203         ;
    204         S OCXTIME=(+$H)
    205         S OCXCKSUM=$$CKSUM(OCXMESS)
    206         ;
    207         S OCXTSP=($H*86400)+$P($H,",",2)
    208         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    209         ;
    210         Q:(OCXTSPL>OCXTSP) 0
    211         ;
    212         K OCXDATA
    213         S OCXDATA(OCXDFN,0)=OCXDFN
    214         S OCXDATA("B",OCXDFN,OCXDFN)=""
    215         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    216         ;
    217         S OCXGR="^OCXD(860.7"
    218         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    219         ;
    220         K OCXDATA
    221         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    222         S OCXDATA(OCXRUL,"M")=OCXMESS
    223         S OCXDATA("B",OCXRUL,OCXRUL)=""
    224         S OCXGR=OCXGR_","_OCXDFN_",1"
    225         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    226         ;
    227         K OCXDATA
    228         S OCXDATA(OCXREL,0)=OCXREL
    229         S OCXDATA("B",OCXREL,OCXREL)=""
    230         S OCXGR=OCXGR_","_OCXRUL_",1"
    231         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    232         ;
    233         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    234         .;
    235         .N OCXGR1
    236         .S OCXGR1=OCXGR_","_OCXREL_",1"
    237         .K OCXDATA
    238         .S OCXDATA(OCXELE,0)=OCXELE
    239         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    240         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    241         .S OCXDATA("B",OCXELE,OCXELE)=""
    242         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    243         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    244         .;
    245         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    246         ..N OCXGR2
    247         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    248         ..K OCXDATA
    249         ..S OCXDATA(OCXDFI,0)=OCXDFI
    250         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    251         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    252         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    253         ;
    254         Q 1
    255         ;
    256 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    257         M @ROOT=DATA
    258         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    259         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    260         ;
    261         Q
    262         ;
    263         ;
     1OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R11R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER'
     14 ;  Called from R11R2A+12^OCXOZ0L.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; NEWRULE( ---------> NEW RULE MESSAGE
     21 ;
     22 Q:$D(OCXRULE("R11R2B"))
     23 ;
     24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     25 S OCXCMSG=""
     26 S OCXNMSG="Imaging request held: "_$$GETDATA(DFN,"30^100",105)
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Notification
     31 ;
     32 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     38 .S OCXNUM=+$P(OCXORD,U,2)
     39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     40 S OCXRULE("R11R2B")=""
     41 I $$NEWRULE(DFN,OCXNUM,11,2,26,OCXNMSG) D  I 1
     42 .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     43 Q
     44 ;
     45R11R3A ; Verify all Event/Elements of  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER'
     46 ;  Called from EL100+7^OCXOZ0G, and EL32+5^OCXOZ0G.
     47 ;
     48 Q:$G(OCXOERR)
     49 ;
     50 ;      Local Extrinsic Functions
     51 ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
     52 ; MCE32( ----------->  Verify Event/Element: 'RADIOLOGY ORDER DISCONTINUED'
     53 ;
     54 Q:$G(^OCXS(860.2,11,"INACT"))
     55 ;
     56 I $$MCE32 D
     57 .I $$MCE100 D R11R3B
     58 Q
     59 ;
     60R11R3B ; Send Order Check, Notication messages and/or Execute code for  Rule #11 'IMAGING REQUEST CANCELLED/HELD'  Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER'
     61 ;  Called from R11R3A+12.
     62 ;
     63 Q:$G(OCXOERR)
     64 ;
     65 ;      Local Extrinsic Functions
     66 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     67 ; NEWRULE( ---------> NEW RULE MESSAGE
     68 ;
     69 Q:$D(OCXRULE("R11R3B"))
     70 ;
     71 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     72 S OCXCMSG=""
     73 S OCXNMSG="Imaging request discontinued: "_$$GETDATA(DFN,"32^100",105)
     74 ;
     75 Q:$G(OCXOERR)
     76 ;
     77 ; Send Notification
     78 ;
     79 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     80 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     81 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     82 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     83 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     84 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     85 .S OCXNUM=+$P(OCXORD,U,2)
     86 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     87 S OCXRULE("R11R3B")=""
     88 I $$NEWRULE(DFN,OCXNUM,11,3,26,OCXNMSG) D  I 1
     89 .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     90 Q
     91 ;
     92R16R1A ; Verify all Event/Elements of  Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SERVICE'
     93 ;  Called from EL46+5^OCXOZ0G.
     94 ;
     95 Q:$G(OCXOERR)
     96 ;
     97 ;      Local Extrinsic Functions
     98 ; MCE46( ----------->  Verify Event/Element: 'SERVICE ORDER REQUIRES CHART SIGNATURE'
     99 ;
     100 Q:$G(^OCXS(860.2,16,"INACT"))
     101 ;
     102 I $$MCE46 D R16R1B
     103 Q
     104 ;
     105R16R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'  Relation #1 'SERVICE'
     106 ;  Called from R16R1A+10.
     107 ;
     108 Q:$G(OCXOERR)
     109 ;
     110 ;      Local Extrinsic Functions
     111 ; NEWRULE( ---------> NEW RULE MESSAGE
     112 ;
     113 Q:$D(OCXRULE("R16R1B"))
     114 ;
     115 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     116 S OCXCMSG=""
     117 S OCXNMSG="Service order - requires chart signature."
     118 ;
     119 Q:$G(OCXOERR)
     120 ;
     121 ; Send Notification
     122 ;
     123 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     124 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     125 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     126 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     127 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     128 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     129 .S OCXNUM=+$P(OCXORD,U,2)
     130 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     131 S OCXRULE("R16R1B")=""
     132 I $$NEWRULE(DFN,OCXNUM,16,1,28,OCXNMSG) D  I 1
     133 .D:($G(OCXTRACE)<5) EN^ORB3(28,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     134 Q
     135 ;
     136R18R1A ; Verify all Event/Elements of  Rule #18 'STAT RESULTS AVAILABLE'  Relation #1 'STAT LAB RESULT'
     137 ;  Called from EL76+5^OCXOZ0G.
     138 ;
     139 Q:$G(OCXOERR)
     140 ;
     141 ;      Local Extrinsic Functions
     142 ; MCE76( ----------->  Verify Event/Element: 'STAT LAB RESULT'
     143 ;
     144 Q:$G(^OCXS(860.2,18,"INACT"))
     145 ;
     146 I $$MCE76 D R18R1B^OCXOZ0N
     147 Q
     148 ;
     149CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     150 ;
     151 N CKSUM,PTR,ASC S CKSUM=0
     152 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     153 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     154 Q +CKSUM
     155 ;
     156GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     157 ;
     158 N OCXE,VAL,PC S VAL=""
     159 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     160 Q VAL
     161 ;
     162MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER
     163 ;
     164 ;
     165 N OCXRES
     166 I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37)
     167 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100))
     168 Q 0
     169 ;
     170MCE32() ; Verify Event/Element: RADIOLOGY ORDER DISCONTINUED
     171 ;
     172 ;
     173 N OCXRES
     174 I $L(OCXDF(37)) S OCXRES(32,37)=OCXDF(37)
     175 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),32)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),32))
     176 Q 0
     177 ;
     178MCE46() ; Verify Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE
     179 ;
     180 ;  OCXDF(37) -> PATIENT IEN data field
     181 ;
     182 N OCXRES
     183 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(46,37)=OCXDF(37)
     184 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),46)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),46))
     185 Q 0
     186 ;
     187MCE76() ; Verify Event/Element: STAT LAB RESULT
     188 ;
     189 ;
     190 N OCXRES
     191 I $L(OCXDF(37)) S OCXRES(76,37)=OCXDF(37)
     192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),76)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),76))
     193 Q 0
     194 ;
     195NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     196 ;
     197 ;
     198 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     199 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     200 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     201 ;
     202 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     203 ;
     204 S OCXTIME=(+$H)
     205 S OCXCKSUM=$$CKSUM(OCXMESS)
     206 ;
     207 S OCXTSP=($H*86400)+$P($H,",",2)
     208 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     209 ;
     210 Q:(OCXTSPL>OCXTSP) 0
     211 ;
     212 K OCXDATA
     213 S OCXDATA(OCXDFN,0)=OCXDFN
     214 S OCXDATA("B",OCXDFN,OCXDFN)=""
     215 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     216 ;
     217 S OCXGR="^OCXD(860.7"
     218 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     219 ;
     220 K OCXDATA
     221 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     222 S OCXDATA(OCXRUL,"M")=OCXMESS
     223 S OCXDATA("B",OCXRUL,OCXRUL)=""
     224 S OCXGR=OCXGR_","_OCXDFN_",1"
     225 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     226 ;
     227 K OCXDATA
     228 S OCXDATA(OCXREL,0)=OCXREL
     229 S OCXDATA("B",OCXREL,OCXREL)=""
     230 S OCXGR=OCXGR_","_OCXRUL_",1"
     231 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     232 ;
     233 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     234 .;
     235 .N OCXGR1
     236 .S OCXGR1=OCXGR_","_OCXREL_",1"
     237 .K OCXDATA
     238 .S OCXDATA(OCXELE,0)=OCXELE
     239 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     240 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     241 .S OCXDATA("B",OCXELE,OCXELE)=""
     242 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     243 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     244 .;
     245 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     246 ..N OCXGR2
     247 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     248 ..K OCXDATA
     249 ..S OCXDATA(OCXDFI,0)=OCXDFI
     250 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     251 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     252 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     253 ;
     254 Q 1
     255 ;
     256SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     257 M @ROOT=DATA
     258 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     259 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     260 ;
     261 Q
     262 ;
     263 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m

    r613 r623  
    1 OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R18R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #18 'STAT RESULTS AVAILABLE'  Relation #1 'STAT LAB RESULT'
    14         ;  Called from R18R1A+10^OCXOZ0M.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; NEWRULE( ---------> NEW RULE MESSAGE
    21         ;
    22         Q:$D(OCXRULE("R18R1B"))
    23         ;
    24         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    25         S OCXCMSG=""
    26         S OCXNMSG="STAT lab results: ["_$$GETDATA(DFN,"76^",96)_"]"
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Notification
    31         ;
    32         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    33         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    34         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    35         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    36         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    37         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    38         .S OCXNUM=+$P(OCXORD,U,2)
    39         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    40         S OCXRULE("R18R1B")=""
    41         I $$NEWRULE(DFN,OCXNUM,18,1,44,OCXNMSG) D  I 1
    42         .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    43         Q
    44         ;
    45 R18R2A  ; Verify all Event/Elements of  Rule #18 'STAT RESULTS AVAILABLE'  Relation #2 'STAT IMAGING RESULT'
    46         ;  Called from EL75+5^OCXOZ0G.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ;      Local Extrinsic Functions
    51         ; MCE75( ----------->  Verify Event/Element: 'STAT IMAGING RESULT'
    52         ;
    53         Q:$G(^OCXS(860.2,18,"INACT"))
    54         ;
    55         I $$MCE75 D R18R2B
    56         Q
    57         ;
    58 R18R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #18 'STAT RESULTS AVAILABLE'  Relation #2 'STAT IMAGING RESULT'
    59         ;  Called from R18R2A+10.
    60         ;
    61         Q:$G(OCXOERR)
    62         ;
    63         ;      Local Extrinsic Functions
    64         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    65         ; NEWRULE( ---------> NEW RULE MESSAGE
    66         ;
    67         Q:$D(OCXRULE("R18R2B"))
    68         ;
    69         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    70         S OCXCMSG=""
    71         S OCXNMSG="STAT imaging results: "_$$GETDATA(DFN,"75^",24)
    72         ;
    73         Q:$G(OCXOERR)
    74         ;
    75         ; Send Notification
    76         ;
    77         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    78         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    79         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    80         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    81         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    82         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    83         .S OCXNUM=+$P(OCXORD,U,2)
    84         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    85         S OCXRULE("R18R2B")=""
    86         I $$NEWRULE(DFN,OCXNUM,18,2,44,OCXNMSG) D  I 1
    87         .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    88         Q
    89         ;
    90 R18R3A  ; Verify all Event/Elements of  Rule #18 'STAT RESULTS AVAILABLE'  Relation #3 'STAT CONSULT RESULT'
    91         ;  Called from EL110+5^OCXOZ0G.
    92         ;
    93         Q:$G(OCXOERR)
    94         ;
    95         ;      Local Extrinsic Functions
    96         ; MCE110( ---------->  Verify Event/Element: 'STAT CONSULT RESULT'
    97         ;
    98         Q:$G(^OCXS(860.2,18,"INACT"))
    99         ;
    100         I $$MCE110 D R18R3B
    101         Q
    102         ;
    103 R18R3B  ; Send Order Check, Notication messages and/or Execute code for  Rule #18 'STAT RESULTS AVAILABLE'  Relation #3 'STAT CONSULT RESULT'
    104         ;  Called from R18R3A+10.
    105         ;
    106         Q:$G(OCXOERR)
    107         ;
    108         ;      Local Extrinsic Functions
    109         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    110         ; NEWRULE( ---------> NEW RULE MESSAGE
    111         ;
    112         Q:$D(OCXRULE("R18R3B"))
    113         ;
    114         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    115         S OCXCMSG=""
    116         S OCXNMSG="STAT consult results: "_$$GETDATA(DFN,"110^",24)
    117         ;
    118         Q:$G(OCXOERR)
    119         ;
    120         ; Send Notification
    121         ;
    122         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    123         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    124         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    125         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    126         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    127         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    128         .S OCXNUM=+$P(OCXORD,U,2)
    129         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    130         S OCXRULE("R18R3B")=""
    131         I $$NEWRULE(DFN,OCXNUM,18,3,44,OCXNMSG) D  I 1
    132         .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    133         Q
    134         ;
    135 R19R1A  ; Verify all Event/Elements of  Rule #19 'PATIENT DISCHARGE'  Relation #1 'DISCHARGE'
    136         ;  Called from EL56+5^OCXOZ0H.
    137         ;
    138         Q:$G(OCXOERR)
    139         ;
    140         ;      Local Extrinsic Functions
    141         ; MCE56( ----------->  Verify Event/Element: 'PATIENT DISCHARGE'
    142         ;
    143         Q:$G(^OCXS(860.2,19,"INACT"))
    144         ;
    145         I $$MCE56 D R19R1B^OCXOZ0O
    146         Q
    147         ;
    148 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    149         ;
    150         N CKSUM,PTR,ASC S CKSUM=0
    151         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    152         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    153         Q +CKSUM
    154         ;
    155 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    156         ;
    157         N OCXE,VAL,PC S VAL=""
    158         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    159         Q VAL
    160         ;
    161 MCE110()        ; Verify Event/Element: STAT CONSULT RESULT
    162         ;
    163         ;
    164         N OCXRES
    165         I $L(OCXDF(37)) S OCXRES(110,37)=OCXDF(37)
    166         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),110)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),110))
    167         Q 0
    168         ;
    169 MCE56() ; Verify Event/Element: PATIENT DISCHARGE
    170         ;
    171         ;  OCXDF(37) -> PATIENT IEN data field
    172         ;
    173         N OCXRES
    174         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(56,37)=OCXDF(37)
    175         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),56)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),56))
    176         Q 0
    177         ;
    178 MCE75() ; Verify Event/Element: STAT IMAGING RESULT
    179         ;
    180         ;
    181         N OCXRES
    182         I $L(OCXDF(37)) S OCXRES(75,37)=OCXDF(37)
    183         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),75)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),75))
    184         Q 0
    185         ;
    186 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    187         ;
    188         ;
    189         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    190         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    191         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    192         ;
    193         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    194         ;
    195         S OCXTIME=(+$H)
    196         S OCXCKSUM=$$CKSUM(OCXMESS)
    197         ;
    198         S OCXTSP=($H*86400)+$P($H,",",2)
    199         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    200         ;
    201         Q:(OCXTSPL>OCXTSP) 0
    202         ;
    203         K OCXDATA
    204         S OCXDATA(OCXDFN,0)=OCXDFN
    205         S OCXDATA("B",OCXDFN,OCXDFN)=""
    206         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    207         ;
    208         S OCXGR="^OCXD(860.7"
    209         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    210         ;
    211         K OCXDATA
    212         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    213         S OCXDATA(OCXRUL,"M")=OCXMESS
    214         S OCXDATA("B",OCXRUL,OCXRUL)=""
    215         S OCXGR=OCXGR_","_OCXDFN_",1"
    216         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    217         ;
    218         K OCXDATA
    219         S OCXDATA(OCXREL,0)=OCXREL
    220         S OCXDATA("B",OCXREL,OCXREL)=""
    221         S OCXGR=OCXGR_","_OCXRUL_",1"
    222         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    223         ;
    224         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    225         .;
    226         .N OCXGR1
    227         .S OCXGR1=OCXGR_","_OCXREL_",1"
    228         .K OCXDATA
    229         .S OCXDATA(OCXELE,0)=OCXELE
    230         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    231         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    232         .S OCXDATA("B",OCXELE,OCXELE)=""
    233         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    234         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    235         .;
    236         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    237         ..N OCXGR2
    238         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    239         ..K OCXDATA
    240         ..S OCXDATA(OCXDFI,0)=OCXDFI
    241         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    242         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    243         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    244         ;
    245         Q 1
    246         ;
    247 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    248         M @ROOT=DATA
    249         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    250         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    251         ;
    252         Q
    253         ;
    254         ;
     1OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R18R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #18 'STAT RESULTS AVAILABLE'  Relation #1 'STAT LAB RESULT'
     14 ;  Called from R18R1A+10^OCXOZ0M.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; NEWRULE( ---------> NEW RULE MESSAGE
     21 ;
     22 Q:$D(OCXRULE("R18R1B"))
     23 ;
     24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     25 S OCXCMSG=""
     26 S OCXNMSG="STAT lab results: ["_$$GETDATA(DFN,"76^",96)_"]"
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Notification
     31 ;
     32 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     38 .S OCXNUM=+$P(OCXORD,U,2)
     39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     40 S OCXRULE("R18R1B")=""
     41 I $$NEWRULE(DFN,OCXNUM,18,1,44,OCXNMSG) D  I 1
     42 .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     43 Q
     44 ;
     45R18R2A ; Verify all Event/Elements of  Rule #18 'STAT RESULTS AVAILABLE'  Relation #2 'STAT IMAGING RESULT'
     46 ;  Called from EL75+5^OCXOZ0G.
     47 ;
     48 Q:$G(OCXOERR)
     49 ;
     50 ;      Local Extrinsic Functions
     51 ; MCE75( ----------->  Verify Event/Element: 'STAT IMAGING RESULT'
     52 ;
     53 Q:$G(^OCXS(860.2,18,"INACT"))
     54 ;
     55 I $$MCE75 D R18R2B
     56 Q
     57 ;
     58R18R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #18 'STAT RESULTS AVAILABLE'  Relation #2 'STAT IMAGING RESULT'
     59 ;  Called from R18R2A+10.
     60 ;
     61 Q:$G(OCXOERR)
     62 ;
     63 ;      Local Extrinsic Functions
     64 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     65 ; NEWRULE( ---------> NEW RULE MESSAGE
     66 ;
     67 Q:$D(OCXRULE("R18R2B"))
     68 ;
     69 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     70 S OCXCMSG=""
     71 S OCXNMSG="STAT imaging results: "_$$GETDATA(DFN,"75^",24)
     72 ;
     73 Q:$G(OCXOERR)
     74 ;
     75 ; Send Notification
     76 ;
     77 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     78 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     79 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     80 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     81 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     82 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     83 .S OCXNUM=+$P(OCXORD,U,2)
     84 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     85 S OCXRULE("R18R2B")=""
     86 I $$NEWRULE(DFN,OCXNUM,18,2,44,OCXNMSG) D  I 1
     87 .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     88 Q
     89 ;
     90R18R3A ; Verify all Event/Elements of  Rule #18 'STAT RESULTS AVAILABLE'  Relation #3 'STAT CONSULT RESULT'
     91 ;  Called from EL110+5^OCXOZ0G.
     92 ;
     93 Q:$G(OCXOERR)
     94 ;
     95 ;      Local Extrinsic Functions
     96 ; MCE110( ---------->  Verify Event/Element: 'STAT CONSULT RESULT'
     97 ;
     98 Q:$G(^OCXS(860.2,18,"INACT"))
     99 ;
     100 I $$MCE110 D R18R3B
     101 Q
     102 ;
     103R18R3B ; Send Order Check, Notication messages and/or Execute code for  Rule #18 'STAT RESULTS AVAILABLE'  Relation #3 'STAT CONSULT RESULT'
     104 ;  Called from R18R3A+10.
     105 ;
     106 Q:$G(OCXOERR)
     107 ;
     108 ;      Local Extrinsic Functions
     109 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     110 ; NEWRULE( ---------> NEW RULE MESSAGE
     111 ;
     112 Q:$D(OCXRULE("R18R3B"))
     113 ;
     114 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     115 S OCXCMSG=""
     116 S OCXNMSG="STAT consult results: "_$$GETDATA(DFN,"110^",24)
     117 ;
     118 Q:$G(OCXOERR)
     119 ;
     120 ; Send Notification
     121 ;
     122 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     123 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     124 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     125 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     126 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     127 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     128 .S OCXNUM=+$P(OCXORD,U,2)
     129 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     130 S OCXRULE("R18R3B")=""
     131 I $$NEWRULE(DFN,OCXNUM,18,3,44,OCXNMSG) D  I 1
     132 .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     133 Q
     134 ;
     135R19R1A ; Verify all Event/Elements of  Rule #19 'PATIENT DISCHARGE'  Relation #1 'DISCHARGE'
     136 ;  Called from EL56+5^OCXOZ0G.
     137 ;
     138 Q:$G(OCXOERR)
     139 ;
     140 ;      Local Extrinsic Functions
     141 ; MCE56( ----------->  Verify Event/Element: 'PATIENT DISCHARGE'
     142 ;
     143 Q:$G(^OCXS(860.2,19,"INACT"))
     144 ;
     145 I $$MCE56 D R19R1B^OCXOZ0O
     146 Q
     147 ;
     148CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     149 ;
     150 N CKSUM,PTR,ASC S CKSUM=0
     151 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     152 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     153 Q +CKSUM
     154 ;
     155GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     156 ;
     157 N OCXE,VAL,PC S VAL=""
     158 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     159 Q VAL
     160 ;
     161MCE110() ; Verify Event/Element: STAT CONSULT RESULT
     162 ;
     163 ;
     164 N OCXRES
     165 I $L(OCXDF(37)) S OCXRES(110,37)=OCXDF(37)
     166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),110)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),110))
     167 Q 0
     168 ;
     169MCE56() ; Verify Event/Element: PATIENT DISCHARGE
     170 ;
     171 ;  OCXDF(37) -> PATIENT IEN data field
     172 ;
     173 N OCXRES
     174 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(56,37)=OCXDF(37)
     175 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),56)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),56))
     176 Q 0
     177 ;
     178MCE75() ; Verify Event/Element: STAT IMAGING RESULT
     179 ;
     180 ;
     181 N OCXRES
     182 I $L(OCXDF(37)) S OCXRES(75,37)=OCXDF(37)
     183 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),75)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),75))
     184 Q 0
     185 ;
     186NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     187 ;
     188 ;
     189 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     190 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     191 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     192 ;
     193 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     194 ;
     195 S OCXTIME=(+$H)
     196 S OCXCKSUM=$$CKSUM(OCXMESS)
     197 ;
     198 S OCXTSP=($H*86400)+$P($H,",",2)
     199 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     200 ;
     201 Q:(OCXTSPL>OCXTSP) 0
     202 ;
     203 K OCXDATA
     204 S OCXDATA(OCXDFN,0)=OCXDFN
     205 S OCXDATA("B",OCXDFN,OCXDFN)=""
     206 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     207 ;
     208 S OCXGR="^OCXD(860.7"
     209 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     210 ;
     211 K OCXDATA
     212 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     213 S OCXDATA(OCXRUL,"M")=OCXMESS
     214 S OCXDATA("B",OCXRUL,OCXRUL)=""
     215 S OCXGR=OCXGR_","_OCXDFN_",1"
     216 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     217 ;
     218 K OCXDATA
     219 S OCXDATA(OCXREL,0)=OCXREL
     220 S OCXDATA("B",OCXREL,OCXREL)=""
     221 S OCXGR=OCXGR_","_OCXRUL_",1"
     222 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     223 ;
     224 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     225 .;
     226 .N OCXGR1
     227 .S OCXGR1=OCXGR_","_OCXREL_",1"
     228 .K OCXDATA
     229 .S OCXDATA(OCXELE,0)=OCXELE
     230 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     231 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     232 .S OCXDATA("B",OCXELE,OCXELE)=""
     233 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     234 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     235 .;
     236 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     237 ..N OCXGR2
     238 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     239 ..K OCXDATA
     240 ..S OCXDATA(OCXDFI,0)=OCXDFI
     241 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     242 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     243 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     244 ;
     245 Q 1
     246 ;
     247SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     248 M @ROOT=DATA
     249 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     250 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     251 ;
     252 Q
     253 ;
     254 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m

    r613 r623  
    1 OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R19R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #19 'PATIENT DISCHARGE'  Relation #1 'DISCHARGE'
    14         ;  Called from R19R1A+10^OCXOZ0N.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    21         ; NEWRULE( ---------> NEW RULE MESSAGE
    22         ;
    23         Q:$D(OCXRULE("R19R1B"))
    24         ;
    25         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    26         S OCXCMSG=""
    27         S OCXNMSG="Discharged on "_$$INT2DT($$GETDATA(DFN,"56^",26),0)
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ; Send Notification
    32         ;
    33         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    34         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    35         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    36         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    37         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    38         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    39         .S OCXNUM=+$P(OCXORD,U,2)
    40         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    41         S OCXRULE("R19R1B")=""
    42         I $$NEWRULE(DFN,OCXNUM,19,1,35,OCXNMSG) D  I 1
    43         .D:($G(OCXTRACE)<5) EN^ORB3(35,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    44         Q
    45         ;
    46 R22R1A  ; Verify all Event/Elements of  Rule #22 'ORDER REQUIRES CO-SIGNATURE'  Relation #1 'COSIG'
    47         ;  Called from EL47+5^OCXOZ0H.
    48         ;
    49         Q:$G(OCXOERR)
    50         ;
    51         ;      Local Extrinsic Functions
    52         ; MCE47( ----------->  Verify Event/Element: 'ORDER REQUIRES CO-SIGNATURE'
    53         ;
    54         Q:$G(^OCXS(860.2,22,"INACT"))
    55         ;
    56         I $$MCE47 D R22R1B
    57         Q
    58         ;
    59 R22R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #22 'ORDER REQUIRES CO-SIGNATURE'  Relation #1 'COSIG'
    60         ;  Called from R22R1A+10.
    61         ;
    62         Q:$G(OCXOERR)
    63         ;
    64         ;      Local Extrinsic Functions
    65         ; NEWRULE( ---------> NEW RULE MESSAGE
    66         ;
    67         Q:$D(OCXRULE("R22R1B"))
    68         ;
    69         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    70         S OCXCMSG=""
    71         S OCXNMSG="Order requires a co-signature"
    72         ;
    73         Q:$G(OCXOERR)
    74         ;
    75         ; Send Notification
    76         ;
    77         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    78         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    79         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    80         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    81         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    82         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    83         .S OCXNUM=+$P(OCXORD,U,2)
    84         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    85         S OCXRULE("R22R1B")=""
    86         I $$NEWRULE(DFN,OCXNUM,22,1,37,OCXNMSG) D  I 1
    87         .D:($G(OCXTRACE)<5) EN^ORB3(37,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    88         Q
    89         ;
    90 R24R1A  ; Verify all Event/Elements of  Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'  Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...'
    91         ;  Called from EL5+5^OCXOZ0H, and EL49+5^OCXOZ0H, and EL55+5^OCXOZ0H, and EL101+5^OCXOZ0H.
    92         ;
    93         Q:$G(OCXOERR)
    94         ;
    95         ;      Local Extrinsic Functions
    96         ; MCE101( ---------->  Verify Event/Element: 'HL7 FINAL IMAGING RESULT'
    97         ; MCE49( ----------->  Verify Event/Element: 'ORDER FLAGGED FOR RESULTS'
    98         ; MCE5( ------------>  Verify Event/Element: 'HL7 FINAL LAB RESULT'
    99         ; MCE55( ----------->  Verify Event/Element: 'CONSULT FINAL RESULTS'
    100         ;
    101         Q:$G(^OCXS(860.2,24,"INACT"))
    102         ;
    103         I $$MCE49 D
    104         .I $$MCE5 D R24R1B^OCXOZ0P
    105         .I $$MCE101 D R24R1B^OCXOZ0P
    106         .I $$MCE55 D R24R1B^OCXOZ0P
    107         Q
    108         ;
    109 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    110         ;
    111         N CKSUM,PTR,ASC S CKSUM=0
    112         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    113         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    114         Q +CKSUM
    115         ;
    116 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    117         ;
    118         N OCXE,VAL,PC S VAL=""
    119         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    120         Q VAL
    121         ;
    122 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    123         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    124         ;
    125         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    126         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    127         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    128         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    129         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    130         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    131         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    132         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    133         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    134         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    135         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    136         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    137         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    138         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    139         E  S OCXMON=$E(OCXMON+100,2,3)
    140         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    141         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    142         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    143         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    144         Q OCXMON_" "_OCXDAY_","_OCXYR
    145         ;
    146 MCE101()        ; Verify Event/Element: HL7 FINAL IMAGING RESULT
    147         ;
    148         ;
    149         N OCXRES
    150         I $L(OCXDF(37)) S OCXRES(101,37)=OCXDF(37)
    151         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),101)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),101))
    152         Q 0
    153         ;
    154 MCE47() ; Verify Event/Element: ORDER REQUIRES CO-SIGNATURE
    155         ;
    156         ;  OCXDF(37) -> PATIENT IEN data field
    157         ;
    158         N OCXRES
    159         S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(47,37)=OCXDF(37)
    160         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),47)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),47))
    161         Q 0
    162         ;
    163 MCE49() ; Verify Event/Element: ORDER FLAGGED FOR RESULTS
    164         ;
    165         ;
    166         N OCXRES
    167         I $L(OCXDF(37)) S OCXRES(49,37)=OCXDF(37)
    168         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),49)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),49))
    169         Q 0
    170         ;
    171 MCE5()  ; Verify Event/Element: HL7 FINAL LAB RESULT
    172         ;
    173         ;
    174         N OCXRES
    175         I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37)
    176         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5))
    177         Q 0
    178         ;
    179 MCE55() ; Verify Event/Element: CONSULT FINAL RESULTS
    180         ;
    181         ;
    182         N OCXRES
    183         I $L(OCXDF(37)) S OCXRES(55,37)=OCXDF(37)
    184         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),55)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),55))
    185         Q 0
    186         ;
    187 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    188         ;
    189         ;
    190         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    191         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    192         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    193         ;
    194         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    195         ;
    196         S OCXTIME=(+$H)
    197         S OCXCKSUM=$$CKSUM(OCXMESS)
    198         ;
    199         S OCXTSP=($H*86400)+$P($H,",",2)
    200         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    201         ;
    202         Q:(OCXTSPL>OCXTSP) 0
    203         ;
    204         K OCXDATA
    205         S OCXDATA(OCXDFN,0)=OCXDFN
    206         S OCXDATA("B",OCXDFN,OCXDFN)=""
    207         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    208         ;
    209         S OCXGR="^OCXD(860.7"
    210         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    211         ;
    212         K OCXDATA
    213         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    214         S OCXDATA(OCXRUL,"M")=OCXMESS
    215         S OCXDATA("B",OCXRUL,OCXRUL)=""
    216         S OCXGR=OCXGR_","_OCXDFN_",1"
    217         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    218         ;
    219         K OCXDATA
    220         S OCXDATA(OCXREL,0)=OCXREL
    221         S OCXDATA("B",OCXREL,OCXREL)=""
    222         S OCXGR=OCXGR_","_OCXRUL_",1"
    223         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    224         ;
    225         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    226         .;
    227         .N OCXGR1
    228         .S OCXGR1=OCXGR_","_OCXREL_",1"
    229         .K OCXDATA
    230         .S OCXDATA(OCXELE,0)=OCXELE
    231         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    232         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    233         .S OCXDATA("B",OCXELE,OCXELE)=""
    234         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    235         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    236         .;
    237         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    238         ..N OCXGR2
    239         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    240         ..K OCXDATA
    241         ..S OCXDATA(OCXDFI,0)=OCXDFI
    242         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    243         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    244         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    245         ;
    246         Q 1
    247         ;
    248 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    249         M @ROOT=DATA
    250         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    251         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    252         ;
    253         Q
    254         ;
    255         ;
     1OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R19R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #19 'PATIENT DISCHARGE'  Relation #1 'DISCHARGE'
     14 ;  Called from R19R1A+10^OCXOZ0N.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     21 ; NEWRULE( ---------> NEW RULE MESSAGE
     22 ;
     23 Q:$D(OCXRULE("R19R1B"))
     24 ;
     25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     26 S OCXCMSG=""
     27 S OCXNMSG="Discharged on "_$$INT2DT($$GETDATA(DFN,"56^",26),0)
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ; Send Notification
     32 ;
     33 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     39 .S OCXNUM=+$P(OCXORD,U,2)
     40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     41 S OCXRULE("R19R1B")=""
     42 I $$NEWRULE(DFN,OCXNUM,19,1,35,OCXNMSG) D  I 1
     43 .D:($G(OCXTRACE)<5) EN^ORB3(35,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     44 Q
     45 ;
     46R22R1A ; Verify all Event/Elements of  Rule #22 'ORDER REQUIRES CO-SIGNATURE'  Relation #1 'COSIG'
     47 ;  Called from EL47+5^OCXOZ0G.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 ;      Local Extrinsic Functions
     52 ; MCE47( ----------->  Verify Event/Element: 'ORDER REQUIRES CO-SIGNATURE'
     53 ;
     54 Q:$G(^OCXS(860.2,22,"INACT"))
     55 ;
     56 I $$MCE47 D R22R1B
     57 Q
     58 ;
     59R22R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #22 'ORDER REQUIRES CO-SIGNATURE'  Relation #1 'COSIG'
     60 ;  Called from R22R1A+10.
     61 ;
     62 Q:$G(OCXOERR)
     63 ;
     64 ;      Local Extrinsic Functions
     65 ; NEWRULE( ---------> NEW RULE MESSAGE
     66 ;
     67 Q:$D(OCXRULE("R22R1B"))
     68 ;
     69 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     70 S OCXCMSG=""
     71 S OCXNMSG="Order requires a co-signature"
     72 ;
     73 Q:$G(OCXOERR)
     74 ;
     75 ; Send Notification
     76 ;
     77 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     78 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     79 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     80 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     81 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     82 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     83 .S OCXNUM=+$P(OCXORD,U,2)
     84 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     85 S OCXRULE("R22R1B")=""
     86 I $$NEWRULE(DFN,OCXNUM,22,1,37,OCXNMSG) D  I 1
     87 .D:($G(OCXTRACE)<5) EN^ORB3(37,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     88 Q
     89 ;
     90R24R1A ; Verify all Event/Elements of  Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'  Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...'
     91 ;  Called from EL5+5^OCXOZ0H, and EL49+5^OCXOZ0H, and EL55+5^OCXOZ0H, and EL101+5^OCXOZ0H.
     92 ;
     93 Q:$G(OCXOERR)
     94 ;
     95 ;      Local Extrinsic Functions
     96 ; MCE101( ---------->  Verify Event/Element: 'HL7 FINAL IMAGING RESULT'
     97 ; MCE49( ----------->  Verify Event/Element: 'ORDER FLAGGED FOR RESULTS'
     98 ; MCE5( ------------>  Verify Event/Element: 'HL7 FINAL LAB RESULT'
     99 ; MCE55( ----------->  Verify Event/Element: 'CONSULT FINAL RESULTS'
     100 ;
     101 Q:$G(^OCXS(860.2,24,"INACT"))
     102 ;
     103 I $$MCE49 D
     104 .I $$MCE5 D R24R1B^OCXOZ0P
     105 .I $$MCE101 D R24R1B^OCXOZ0P
     106 .I $$MCE55 D R24R1B^OCXOZ0P
     107 Q
     108 ;
     109CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     110 ;
     111 N CKSUM,PTR,ASC S CKSUM=0
     112 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     113 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     114 Q +CKSUM
     115 ;
     116GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     117 ;
     118 N OCXE,VAL,PC S VAL=""
     119 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     120 Q VAL
     121 ;
     122INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     123 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     124 ;
     125 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     126 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     127 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     128 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     129 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     130 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     131 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     132 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     133 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     134 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     135 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     136 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     137 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     138 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     139 E  S OCXMON=$E(OCXMON+100,2,3)
     140 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     141 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     142 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     143 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     144 Q OCXMON_" "_OCXDAY_","_OCXYR
     145 ;
     146MCE101() ; Verify Event/Element: HL7 FINAL IMAGING RESULT
     147 ;
     148 ;
     149 N OCXRES
     150 I $L(OCXDF(37)) S OCXRES(101,37)=OCXDF(37)
     151 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),101)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),101))
     152 Q 0
     153 ;
     154MCE47() ; Verify Event/Element: ORDER REQUIRES CO-SIGNATURE
     155 ;
     156 ;  OCXDF(37) -> PATIENT IEN data field
     157 ;
     158 N OCXRES
     159 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(47,37)=OCXDF(37)
     160 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),47)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),47))
     161 Q 0
     162 ;
     163MCE49() ; Verify Event/Element: ORDER FLAGGED FOR RESULTS
     164 ;
     165 ;
     166 N OCXRES
     167 I $L(OCXDF(37)) S OCXRES(49,37)=OCXDF(37)
     168 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),49)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),49))
     169 Q 0
     170 ;
     171MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT
     172 ;
     173 ;
     174 N OCXRES
     175 I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37)
     176 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5))
     177 Q 0
     178 ;
     179MCE55() ; Verify Event/Element: CONSULT FINAL RESULTS
     180 ;
     181 ;
     182 N OCXRES
     183 I $L(OCXDF(37)) S OCXRES(55,37)=OCXDF(37)
     184 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),55)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),55))
     185 Q 0
     186 ;
     187NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     188 ;
     189 ;
     190 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     191 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     192 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     193 ;
     194 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     195 ;
     196 S OCXTIME=(+$H)
     197 S OCXCKSUM=$$CKSUM(OCXMESS)
     198 ;
     199 S OCXTSP=($H*86400)+$P($H,",",2)
     200 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     201 ;
     202 Q:(OCXTSPL>OCXTSP) 0
     203 ;
     204 K OCXDATA
     205 S OCXDATA(OCXDFN,0)=OCXDFN
     206 S OCXDATA("B",OCXDFN,OCXDFN)=""
     207 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     208 ;
     209 S OCXGR="^OCXD(860.7"
     210 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     211 ;
     212 K OCXDATA
     213 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     214 S OCXDATA(OCXRUL,"M")=OCXMESS
     215 S OCXDATA("B",OCXRUL,OCXRUL)=""
     216 S OCXGR=OCXGR_","_OCXDFN_",1"
     217 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     218 ;
     219 K OCXDATA
     220 S OCXDATA(OCXREL,0)=OCXREL
     221 S OCXDATA("B",OCXREL,OCXREL)=""
     222 S OCXGR=OCXGR_","_OCXRUL_",1"
     223 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     224 ;
     225 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     226 .;
     227 .N OCXGR1
     228 .S OCXGR1=OCXGR_","_OCXREL_",1"
     229 .K OCXDATA
     230 .S OCXDATA(OCXELE,0)=OCXELE
     231 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     232 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     233 .S OCXDATA("B",OCXELE,OCXELE)=""
     234 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     235 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     236 .;
     237 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     238 ..N OCXGR2
     239 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     240 ..K OCXDATA
     241 ..S OCXDATA(OCXDFI,0)=OCXDFI
     242 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     243 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     244 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     245 ;
     246 Q 1
     247 ;
     248SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     249 M @ROOT=DATA
     250 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     251 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     252 ;
     253 Q
     254 ;
     255 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m

    r613 r623  
    1 OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R24R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'  Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...'
    14         ;  Called from R24R1A+14^OCXOZ0O.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; NEWRULE( ---------> NEW RULE MESSAGE
    21         ;
    22         Q:$D(OCXRULE("R24R1B"))
    23         ;
    24         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    25         S OCXCMSG=""
    26         S OCXNMSG="Requested results available: "_$$GETDATA(DFN,"5^49^55^101",96)
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Notification
    31         ;
    32         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    33         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    34         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    35         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    36         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    37         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    38         .S OCXNUM=+$P(OCXORD,U,2)
    39         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    40         S OCXRULE("R24R1B")=""
    41         I $$NEWRULE(DFN,OCXNUM,24,1,33,OCXNMSG) D  I 1
    42         .D:($G(OCXTRACE)<5) EN^ORB3(33,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    43         Q
    44         ;
    45 R28R1A  ; Verify all Event/Elements of  Rule #28 'STAT ORDER PLACED'  Relation #1 'NEW OBR STAT OR NEW ORC STAT'
    46         ;  Called from EL60+5^OCXOZ0H, and EL61+5^OCXOZ0H.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ;      Local Extrinsic Functions
    51         ; MCE60( ----------->  Verify Event/Element: 'NEW OBR STAT ORDER'
    52         ; MCE61( ----------->  Verify Event/Element: 'NEW ORC STAT ORDER'
    53         ;
    54         Q:$G(^OCXS(860.2,28,"INACT"))
    55         ;
    56         I $$MCE60 D R28R1B
    57         I $$MCE61 D R28R1B
    58         Q
    59         ;
    60 R28R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #28 'STAT ORDER PLACED'  Relation #1 'NEW OBR STAT OR NEW ORC STAT'
    61         ;  Called from R28R1A+11.
    62         ;
    63         Q:$G(OCXOERR)
    64         ;
    65         ;      Local Extrinsic Functions
    66         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    67         ; NEWRULE( ---------> NEW RULE MESSAGE
    68         ;
    69         Q:$D(OCXRULE("R28R1B"))
    70         ;
    71         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    72         S OCXCMSG=""
    73         S OCXNMSG="STAT order: "_$$GETDATA(DFN,"60^61",96)
    74         ;
    75         Q:$G(OCXOERR)
    76         ;
    77         ; Send Notification
    78         ;
    79         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    80         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    81         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    82         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    83         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    84         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    85         .S OCXNUM=+$P(OCXORD,U,2)
    86         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    87         S OCXRULE("R28R1B")=""
    88         I $$NEWRULE(DFN,OCXNUM,28,1,43,OCXNMSG) D  I 1
    89         .D:($G(OCXTRACE)<5) EN^ORB3(43,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    90         Q
    91         ;
    92 R32R1A  ; Verify all Event/Elements of  Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...'  Relation #1 'FROM PSYCH WARD'
    93         ;  Called from EL42+5^OCXOZ0H.
    94         ;
    95         Q:$G(OCXOERR)
    96         ;
    97         ;      Local Extrinsic Functions
    98         ; MCE42( ----------->  Verify Event/Element: 'PATIENT TRANSFERRED FROM PSYCH WARD'
    99         ;
    100         Q:$G(^OCXS(860.2,32,"INACT"))
    101         ;
    102         I $$MCE42 D R32R1B
    103         Q
    104         ;
    105 R32R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...'  Relation #1 'FROM PSYCH WARD'
    106         ;  Called from R32R1A+10.
    107         ;
    108         Q:$G(OCXOERR)
    109         ;
    110         ;      Local Extrinsic Functions
    111         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    112         ; NEWRULE( ---------> NEW RULE MESSAGE
    113         ;
    114         Q:$D(OCXRULE("R32R1B"))
    115         ;
    116         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    117         S OCXCMSG=""
    118         S OCXNMSG="Transfer from Psych ward: "_$$GETDATA(DFN,"42^",95)_" to ward: "_$$GETDATA(DFN,"42^",90)
    119         ;
    120         Q:$G(OCXOERR)
    121         ;
    122         ; Send Notification
    123         ;
    124         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    125         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    126         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    127         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    128         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    129         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    130         .S OCXNUM=+$P(OCXORD,U,2)
    131         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    132         S OCXRULE("R32R1B")=""
    133         I $$NEWRULE(DFN,OCXNUM,32,1,36,OCXNMSG) D  I 1
    134         .D:($G(OCXTRACE)<5) EN^ORB3(36,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    135         Q
    136         ;
    137 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    138         ;
    139         N CKSUM,PTR,ASC S CKSUM=0
    140         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    141         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    142         Q +CKSUM
    143         ;
    144 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    145         ;
    146         N OCXE,VAL,PC S VAL=""
    147         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    148         Q VAL
    149         ;
    150 MCE42() ; Verify Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD
    151         ;
    152         ;  OCXDF(37) -> PATIENT IEN data field
    153         ;
    154         N OCXRES
    155         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(42,37)=OCXDF(37)
    156         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),42)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),42))
    157         Q 0
    158         ;
    159 MCE60() ; Verify Event/Element: NEW OBR STAT ORDER
    160         ;
    161         ;
    162         N OCXRES
    163         I $L(OCXDF(37)) S OCXRES(60,37)=OCXDF(37)
    164         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),60)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),60))
    165         Q 0
    166         ;
    167 MCE61() ; Verify Event/Element: NEW ORC STAT ORDER
    168         ;
    169         ;
    170         N OCXRES
    171         I $L(OCXDF(37)) S OCXRES(61,37)=OCXDF(37)
    172         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),61)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),61))
    173         Q 0
    174         ;
    175 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    176         ;
    177         ;
    178         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    179         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    180         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    181         ;
    182         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    183         ;
    184         S OCXTIME=(+$H)
    185         S OCXCKSUM=$$CKSUM(OCXMESS)
    186         ;
    187         S OCXTSP=($H*86400)+$P($H,",",2)
    188         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    189         ;
    190         Q:(OCXTSPL>OCXTSP) 0
    191         ;
    192         K OCXDATA
    193         S OCXDATA(OCXDFN,0)=OCXDFN
    194         S OCXDATA("B",OCXDFN,OCXDFN)=""
    195         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    196         ;
    197         S OCXGR="^OCXD(860.7"
    198         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    199         ;
    200         K OCXDATA
    201         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    202         S OCXDATA(OCXRUL,"M")=OCXMESS
    203         S OCXDATA("B",OCXRUL,OCXRUL)=""
    204         S OCXGR=OCXGR_","_OCXDFN_",1"
    205         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    206         ;
    207         K OCXDATA
    208         S OCXDATA(OCXREL,0)=OCXREL
    209         S OCXDATA("B",OCXREL,OCXREL)=""
    210         S OCXGR=OCXGR_","_OCXRUL_",1"
    211         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    212         ;
    213         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    214         .;
    215         .N OCXGR1
    216         .S OCXGR1=OCXGR_","_OCXREL_",1"
    217         .K OCXDATA
    218         .S OCXDATA(OCXELE,0)=OCXELE
    219         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    220         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    221         .S OCXDATA("B",OCXELE,OCXELE)=""
    222         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    223         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    224         .;
    225         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    226         ..N OCXGR2
    227         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    228         ..K OCXDATA
    229         ..S OCXDATA(OCXDFI,0)=OCXDFI
    230         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    231         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    232         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    233         ;
    234         Q 1
    235         ;
    236 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    237         M @ROOT=DATA
    238         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    239         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    240         ;
    241         Q
    242         ;
    243         ;
     1OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R24R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE'  Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...'
     14 ;  Called from R24R1A+14^OCXOZ0O.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; NEWRULE( ---------> NEW RULE MESSAGE
     21 ;
     22 Q:$D(OCXRULE("R24R1B"))
     23 ;
     24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     25 S OCXCMSG=""
     26 S OCXNMSG="Requested results available: "_$$GETDATA(DFN,"5^49^55^101",96)
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Notification
     31 ;
     32 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     38 .S OCXNUM=+$P(OCXORD,U,2)
     39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     40 S OCXRULE("R24R1B")=""
     41 I $$NEWRULE(DFN,OCXNUM,24,1,33,OCXNMSG) D  I 1
     42 .D:($G(OCXTRACE)<5) EN^ORB3(33,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     43 Q
     44 ;
     45R28R1A ; Verify all Event/Elements of  Rule #28 'STAT ORDER PLACED'  Relation #1 'NEW OBR STAT OR NEW ORC STAT'
     46 ;  Called from EL60+5^OCXOZ0H, and EL61+5^OCXOZ0H.
     47 ;
     48 Q:$G(OCXOERR)
     49 ;
     50 ;      Local Extrinsic Functions
     51 ; MCE60( ----------->  Verify Event/Element: 'NEW OBR STAT ORDER'
     52 ; MCE61( ----------->  Verify Event/Element: 'NEW ORC STAT ORDER'
     53 ;
     54 Q:$G(^OCXS(860.2,28,"INACT"))
     55 ;
     56 I $$MCE60 D R28R1B
     57 I $$MCE61 D R28R1B
     58 Q
     59 ;
     60R28R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #28 'STAT ORDER PLACED'  Relation #1 'NEW OBR STAT OR NEW ORC STAT'
     61 ;  Called from R28R1A+11.
     62 ;
     63 Q:$G(OCXOERR)
     64 ;
     65 ;      Local Extrinsic Functions
     66 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     67 ; NEWRULE( ---------> NEW RULE MESSAGE
     68 ;
     69 Q:$D(OCXRULE("R28R1B"))
     70 ;
     71 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     72 S OCXCMSG=""
     73 S OCXNMSG="STAT order: "_$$GETDATA(DFN,"60^61",96)
     74 ;
     75 Q:$G(OCXOERR)
     76 ;
     77 ; Send Notification
     78 ;
     79 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     80 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     81 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     82 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     83 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     84 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     85 .S OCXNUM=+$P(OCXORD,U,2)
     86 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     87 S OCXRULE("R28R1B")=""
     88 I $$NEWRULE(DFN,OCXNUM,28,1,43,OCXNMSG) D  I 1
     89 .D:($G(OCXTRACE)<5) EN^ORB3(43,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     90 Q
     91 ;
     92R32R1A ; Verify all Event/Elements of  Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...'  Relation #1 'FROM PSYCH WARD'
     93 ;  Called from EL42+5^OCXOZ0H.
     94 ;
     95 Q:$G(OCXOERR)
     96 ;
     97 ;      Local Extrinsic Functions
     98 ; MCE42( ----------->  Verify Event/Element: 'PATIENT TRANSFERRED FROM PSYCH WARD'
     99 ;
     100 Q:$G(^OCXS(860.2,32,"INACT"))
     101 ;
     102 I $$MCE42 D R32R1B
     103 Q
     104 ;
     105R32R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...'  Relation #1 'FROM PSYCH WARD'
     106 ;  Called from R32R1A+10.
     107 ;
     108 Q:$G(OCXOERR)
     109 ;
     110 ;      Local Extrinsic Functions
     111 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     112 ; NEWRULE( ---------> NEW RULE MESSAGE
     113 ;
     114 Q:$D(OCXRULE("R32R1B"))
     115 ;
     116 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     117 S OCXCMSG=""
     118 S OCXNMSG="Transfer from Psych ward: "_$$GETDATA(DFN,"42^",95)_" to ward: "_$$GETDATA(DFN,"42^",90)
     119 ;
     120 Q:$G(OCXOERR)
     121 ;
     122 ; Send Notification
     123 ;
     124 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     125 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     126 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     127 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     128 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     129 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     130 .S OCXNUM=+$P(OCXORD,U,2)
     131 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     132 S OCXRULE("R32R1B")=""
     133 I $$NEWRULE(DFN,OCXNUM,32,1,36,OCXNMSG) D  I 1
     134 .D:($G(OCXTRACE)<5) EN^ORB3(36,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     135 Q
     136 ;
     137CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     138 ;
     139 N CKSUM,PTR,ASC S CKSUM=0
     140 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     141 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     142 Q +CKSUM
     143 ;
     144GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     145 ;
     146 N OCXE,VAL,PC S VAL=""
     147 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     148 Q VAL
     149 ;
     150MCE42() ; Verify Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD
     151 ;
     152 ;  OCXDF(37) -> PATIENT IEN data field
     153 ;
     154 N OCXRES
     155 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(42,37)=OCXDF(37)
     156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),42)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),42))
     157 Q 0
     158 ;
     159MCE60() ; Verify Event/Element: NEW OBR STAT ORDER
     160 ;
     161 ;
     162 N OCXRES
     163 I $L(OCXDF(37)) S OCXRES(60,37)=OCXDF(37)
     164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),60)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),60))
     165 Q 0
     166 ;
     167MCE61() ; Verify Event/Element: NEW ORC STAT ORDER
     168 ;
     169 ;
     170 N OCXRES
     171 I $L(OCXDF(37)) S OCXRES(61,37)=OCXDF(37)
     172 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),61)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),61))
     173 Q 0
     174 ;
     175NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     176 ;
     177 ;
     178 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     179 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     180 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     181 ;
     182 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     183 ;
     184 S OCXTIME=(+$H)
     185 S OCXCKSUM=$$CKSUM(OCXMESS)
     186 ;
     187 S OCXTSP=($H*86400)+$P($H,",",2)
     188 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     189 ;
     190 Q:(OCXTSPL>OCXTSP) 0
     191 ;
     192 K OCXDATA
     193 S OCXDATA(OCXDFN,0)=OCXDFN
     194 S OCXDATA("B",OCXDFN,OCXDFN)=""
     195 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     196 ;
     197 S OCXGR="^OCXD(860.7"
     198 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     199 ;
     200 K OCXDATA
     201 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     202 S OCXDATA(OCXRUL,"M")=OCXMESS
     203 S OCXDATA("B",OCXRUL,OCXRUL)=""
     204 S OCXGR=OCXGR_","_OCXDFN_",1"
     205 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     206 ;
     207 K OCXDATA
     208 S OCXDATA(OCXREL,0)=OCXREL
     209 S OCXDATA("B",OCXREL,OCXREL)=""
     210 S OCXGR=OCXGR_","_OCXRUL_",1"
     211 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     212 ;
     213 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     214 .;
     215 .N OCXGR1
     216 .S OCXGR1=OCXGR_","_OCXREL_",1"
     217 .K OCXDATA
     218 .S OCXDATA(OCXELE,0)=OCXELE
     219 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     220 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     221 .S OCXDATA("B",OCXELE,OCXELE)=""
     222 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     223 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     224 .;
     225 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     226 ..N OCXGR2
     227 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     228 ..K OCXDATA
     229 ..S OCXDATA(OCXDFI,0)=OCXDFI
     230 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     231 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     232 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     233 ;
     234 Q 1
     235 ;
     236SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     237 M @ROOT=DATA
     238 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     239 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     240 ;
     241 Q
     242 ;
     243 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m

    r613 r623  
    1 OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R35R1A  ; Verify all Event/Elements of  Rule #35 'LAB ORDER CANCELLED'  Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...'
    14         ;  Called from EL100+8^OCXOZ0G, and EL20+5^OCXOZ0H, and EL40+5^OCXOZ0H.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
    20         ; MCE20( ----------->  Verify Event/Element: 'HL7 LAB ORDER CANCELLED'
    21         ; MCE40( ----------->  Verify Event/Element: 'HL7 LAB REQUEST CANCELLED'
    22         ;
    23         Q:$G(^OCXS(860.2,35,"INACT"))
    24         ;
    25         I $$MCE20 D
    26         .I $$MCE100 D R35R1B
    27         I $$MCE40 D
    28         .I $$MCE100 D R35R1B
    29         Q
    30         ;
    31 R35R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #35 'LAB ORDER CANCELLED'  Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...'
    32         ;  Called from R35R1A+13.
    33         ;
    34         Q:$G(OCXOERR)
    35         ;
    36         ;      Local Extrinsic Functions
    37         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    38         ; NEWRULE( ---------> NEW RULE MESSAGE
    39         ;
    40         Q:$D(OCXRULE("R35R1B"))
    41         ;
    42         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    43         S OCXCMSG=""
    44         S OCXNMSG="Lab order canceled: "_$$GETDATA(DFN,"20^40^100",105)
    45         ;
    46         Q:$G(OCXOERR)
    47         ;
    48         ; Send Notification
    49         ;
    50         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    51         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    52         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    53         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    54         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    55         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    56         .S OCXNUM=+$P(OCXORD,U,2)
    57         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    58         S OCXRULE("R35R1B")=""
    59         I $$NEWRULE(DFN,OCXNUM,35,1,42,OCXNMSG) D  I 1
    60         .D:($G(OCXTRACE)<5) EN^ORB3(42,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    61         Q
    62         ;
    63 R38R1A  ; Verify all Event/Elements of  Rule #38 'NEW ORDER PLACED'  Relation #1 'NEW'
    64         ;  Called from EL6+5^OCXOZ0H.
    65         ;
    66         Q:$G(OCXOERR)
    67         ;
    68         ;      Local Extrinsic Functions
    69         ; MCE6( ------------>  Verify Event/Element: 'HL7 NEW OERR ORDER'
    70         ;
    71         Q:$G(^OCXS(860.2,38,"INACT"))
    72         ;
    73         I $$MCE6 D R38R1B
    74         Q
    75         ;
    76 R38R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #38 'NEW ORDER PLACED'  Relation #1 'NEW'
    77         ;  Called from R38R1A+10.
    78         ;
    79         Q:$G(OCXOERR)
    80         ;
    81         ;      Local Extrinsic Functions
    82         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    83         ; NEWRULE( ---------> NEW RULE MESSAGE
    84         ;
    85         Q:$D(OCXRULE("R38R1B"))
    86         ;
    87         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    88         S OCXCMSG=""
    89         S OCXNMSG="["_$$GETDATA(DFN,"6^",147)_"] New order(s) placed."
    90         ;
    91         Q:$G(OCXOERR)
    92         ;
    93         ; Send Notification
    94         ;
    95         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    96         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    97         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    98         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    99         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    100         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    101         .S OCXNUM=+$P(OCXORD,U,2)
    102         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    103         S OCXRULE("R38R1B")=""
    104         I $$NEWRULE(DFN,OCXNUM,38,1,50,OCXNMSG) D  I 1
    105         .D:($G(OCXTRACE)<5) EN^ORB3(50,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    106         Q
    107         ;
    108 R38R2A  ; Verify all Event/Elements of  Rule #38 'NEW ORDER PLACED'  Relation #2 'DCED'
    109         ;  Called from EL126+5^OCXOZ0H.
    110         ;
    111         Q:$G(OCXOERR)
    112         ;
    113         ;      Local Extrinsic Functions
    114         ; MCE126( ---------->  Verify Event/Element: 'HL7 DCED OERR ORDER'
    115         ;
    116         Q:$G(^OCXS(860.2,38,"INACT"))
    117         ;
    118         I $$MCE126 D R38R2B
    119         Q
    120         ;
    121 R38R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #38 'NEW ORDER PLACED'  Relation #2 'DCED'
    122         ;  Called from R38R2A+10.
    123         ;
    124         Q:$G(OCXOERR)
    125         ;
    126         ;      Local Extrinsic Functions
    127         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    128         ; NEWRULE( ---------> NEW RULE MESSAGE
    129         ;
    130         Q:$D(OCXRULE("R38R2B"))
    131         ;
    132         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    133         S OCXCMSG=""
    134         S OCXNMSG="["_$$GETDATA(DFN,"126^",147)_"] New DC order(s) placed."
    135         ;
    136         Q:$G(OCXOERR)
    137         ;
    138         ; Send Notification
    139         ;
    140         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    141         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    142         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    143         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    144         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    145         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    146         .S OCXNUM=+$P(OCXORD,U,2)
    147         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    148         S OCXRULE("R38R2B")=""
    149         I $$NEWRULE(DFN,OCXNUM,38,2,62,OCXNMSG) D  I 1
    150         .D:($G(OCXTRACE)<5) EN^ORB3(62,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    151         Q
    152         ;
    153 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    154         ;
    155         N CKSUM,PTR,ASC S CKSUM=0
    156         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    157         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    158         Q +CKSUM
    159         ;
    160 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    161         ;
    162         N OCXE,VAL,PC S VAL=""
    163         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    164         Q VAL
    165         ;
    166 MCE100()        ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER
    167         ;
    168         ;
    169         N OCXRES
    170         I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37)
    171         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100))
    172         Q 0
    173         ;
    174 MCE126()        ; Verify Event/Element: HL7 DCED OERR ORDER
    175         ;
    176         ;
    177         N OCXRES
    178         I $L(OCXDF(37)) S OCXRES(126,37)=OCXDF(37)
    179         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),126)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),126))
    180         Q 0
    181         ;
    182 MCE20() ; Verify Event/Element: HL7 LAB ORDER CANCELLED
    183         ;
    184         ;
    185         N OCXRES
    186         I $L(OCXDF(37)) S OCXRES(20,37)=OCXDF(37)
    187         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),20)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),20))
    188         Q 0
    189         ;
    190 MCE40() ; Verify Event/Element: HL7 LAB REQUEST CANCELLED
    191         ;
    192         ;
    193         N OCXRES
    194         I $L(OCXDF(37)) S OCXRES(40,37)=OCXDF(37)
    195         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),40)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),40))
    196         Q 0
    197         ;
    198 MCE6()  ; Verify Event/Element: HL7 NEW OERR ORDER
    199         ;
    200         ;
    201         N OCXRES
    202         I $L(OCXDF(37)) S OCXRES(6,37)=OCXDF(37)
    203         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),6)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),6))
    204         Q 0
    205         ;
    206 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    207         ;
    208         ;
    209         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    210         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    211         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    212         ;
    213         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    214         ;
    215         S OCXTIME=(+$H)
    216         S OCXCKSUM=$$CKSUM(OCXMESS)
    217         ;
    218         S OCXTSP=($H*86400)+$P($H,",",2)
    219         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    220         ;
    221         Q:(OCXTSPL>OCXTSP) 0
    222         ;
    223         K OCXDATA
    224         S OCXDATA(OCXDFN,0)=OCXDFN
    225         S OCXDATA("B",OCXDFN,OCXDFN)=""
    226         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    227         ;
    228         S OCXGR="^OCXD(860.7"
    229         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    230         ;
    231         K OCXDATA
    232         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    233         S OCXDATA(OCXRUL,"M")=OCXMESS
    234         S OCXDATA("B",OCXRUL,OCXRUL)=""
    235         S OCXGR=OCXGR_","_OCXDFN_",1"
    236         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    237         ;
    238         K OCXDATA
    239         S OCXDATA(OCXREL,0)=OCXREL
    240         S OCXDATA("B",OCXREL,OCXREL)=""
    241         S OCXGR=OCXGR_","_OCXRUL_",1"
    242         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    243         ;
    244         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    245         .;
    246         .N OCXGR1
    247         .S OCXGR1=OCXGR_","_OCXREL_",1"
    248         .K OCXDATA
    249         .S OCXDATA(OCXELE,0)=OCXELE
    250         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    251         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    252         .S OCXDATA("B",OCXELE,OCXELE)=""
    253         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    254         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    255         .;
    256         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    257         ..N OCXGR2
    258         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    259         ..K OCXDATA
    260         ..S OCXDATA(OCXDFI,0)=OCXDFI
    261         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    262         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    263         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    264         ;
    265         Q 1
    266         ;
    267 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    268         M @ROOT=DATA
    269         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    270         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    271         ;
    272         Q
    273         ;
    274         ;
     1OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R35R1A ; Verify all Event/Elements of  Rule #35 'LAB ORDER CANCELLED'  Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...'
     14 ;  Called from EL100+8^OCXOZ0G, and EL20+5^OCXOZ0H, and EL40+5^OCXOZ0H.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE100( ---------->  Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER'
     20 ; MCE20( ----------->  Verify Event/Element: 'HL7 LAB ORDER CANCELLED'
     21 ; MCE40( ----------->  Verify Event/Element: 'HL7 LAB REQUEST CANCELLED'
     22 ;
     23 Q:$G(^OCXS(860.2,35,"INACT"))
     24 ;
     25 I $$MCE20 D
     26 .I $$MCE100 D R35R1B
     27 I $$MCE40 D
     28 .I $$MCE100 D R35R1B
     29 Q
     30 ;
     31R35R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #35 'LAB ORDER CANCELLED'  Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...'
     32 ;  Called from R35R1A+13.
     33 ;
     34 Q:$G(OCXOERR)
     35 ;
     36 ;      Local Extrinsic Functions
     37 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     38 ; NEWRULE( ---------> NEW RULE MESSAGE
     39 ;
     40 Q:$D(OCXRULE("R35R1B"))
     41 ;
     42 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     43 S OCXCMSG=""
     44 S OCXNMSG="Lab order canceled: "_$$GETDATA(DFN,"20^40^100",105)
     45 ;
     46 Q:$G(OCXOERR)
     47 ;
     48 ; Send Notification
     49 ;
     50 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     51 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     52 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     53 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     54 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     55 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     56 .S OCXNUM=+$P(OCXORD,U,2)
     57 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     58 S OCXRULE("R35R1B")=""
     59 I $$NEWRULE(DFN,OCXNUM,35,1,42,OCXNMSG) D  I 1
     60 .D:($G(OCXTRACE)<5) EN^ORB3(42,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     61 Q
     62 ;
     63R38R1A ; Verify all Event/Elements of  Rule #38 'NEW ORDER PLACED'  Relation #1 'NEW'
     64 ;  Called from EL6+5^OCXOZ0H.
     65 ;
     66 Q:$G(OCXOERR)
     67 ;
     68 ;      Local Extrinsic Functions
     69 ; MCE6( ------------>  Verify Event/Element: 'HL7 NEW OERR ORDER'
     70 ;
     71 Q:$G(^OCXS(860.2,38,"INACT"))
     72 ;
     73 I $$MCE6 D R38R1B
     74 Q
     75 ;
     76R38R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #38 'NEW ORDER PLACED'  Relation #1 'NEW'
     77 ;  Called from R38R1A+10.
     78 ;
     79 Q:$G(OCXOERR)
     80 ;
     81 ;      Local Extrinsic Functions
     82 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     83 ; NEWRULE( ---------> NEW RULE MESSAGE
     84 ;
     85 Q:$D(OCXRULE("R38R1B"))
     86 ;
     87 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     88 S OCXCMSG=""
     89 S OCXNMSG="["_$$GETDATA(DFN,"6^",147)_"] New order(s) placed."
     90 ;
     91 Q:$G(OCXOERR)
     92 ;
     93 ; Send Notification
     94 ;
     95 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     96 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     97 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     98 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     99 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     100 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     101 .S OCXNUM=+$P(OCXORD,U,2)
     102 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     103 S OCXRULE("R38R1B")=""
     104 I $$NEWRULE(DFN,OCXNUM,38,1,50,OCXNMSG) D  I 1
     105 .D:($G(OCXTRACE)<5) EN^ORB3(50,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     106 Q
     107 ;
     108R38R2A ; Verify all Event/Elements of  Rule #38 'NEW ORDER PLACED'  Relation #2 'DCED'
     109 ;  Called from EL126+5^OCXOZ0H.
     110 ;
     111 Q:$G(OCXOERR)
     112 ;
     113 ;      Local Extrinsic Functions
     114 ; MCE126( ---------->  Verify Event/Element: 'HL7 DCED OERR ORDER'
     115 ;
     116 Q:$G(^OCXS(860.2,38,"INACT"))
     117 ;
     118 I $$MCE126 D R38R2B
     119 Q
     120 ;
     121R38R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #38 'NEW ORDER PLACED'  Relation #2 'DCED'
     122 ;  Called from R38R2A+10.
     123 ;
     124 Q:$G(OCXOERR)
     125 ;
     126 ;      Local Extrinsic Functions
     127 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     128 ; NEWRULE( ---------> NEW RULE MESSAGE
     129 ;
     130 Q:$D(OCXRULE("R38R2B"))
     131 ;
     132 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     133 S OCXCMSG=""
     134 S OCXNMSG="["_$$GETDATA(DFN,"126^",147)_"] New DC order(s) placed."
     135 ;
     136 Q:$G(OCXOERR)
     137 ;
     138 ; Send Notification
     139 ;
     140 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     141 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     142 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     143 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     144 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     145 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     146 .S OCXNUM=+$P(OCXORD,U,2)
     147 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     148 S OCXRULE("R38R2B")=""
     149 I $$NEWRULE(DFN,OCXNUM,38,2,62,OCXNMSG) D  I 1
     150 .D:($G(OCXTRACE)<5) EN^ORB3(62,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     151 Q
     152 ;
     153CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     154 ;
     155 N CKSUM,PTR,ASC S CKSUM=0
     156 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     157 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     158 Q +CKSUM
     159 ;
     160GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     161 ;
     162 N OCXE,VAL,PC S VAL=""
     163 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     164 Q VAL
     165 ;
     166MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER
     167 ;
     168 ;
     169 N OCXRES
     170 I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37)
     171 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100))
     172 Q 0
     173 ;
     174MCE126() ; Verify Event/Element: HL7 DCED OERR ORDER
     175 ;
     176 ;
     177 N OCXRES
     178 I $L(OCXDF(37)) S OCXRES(126,37)=OCXDF(37)
     179 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),126)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),126))
     180 Q 0
     181 ;
     182MCE20() ; Verify Event/Element: HL7 LAB ORDER CANCELLED
     183 ;
     184 ;
     185 N OCXRES
     186 I $L(OCXDF(37)) S OCXRES(20,37)=OCXDF(37)
     187 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),20)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),20))
     188 Q 0
     189 ;
     190MCE40() ; Verify Event/Element: HL7 LAB REQUEST CANCELLED
     191 ;
     192 ;
     193 N OCXRES
     194 I $L(OCXDF(37)) S OCXRES(40,37)=OCXDF(37)
     195 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),40)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),40))
     196 Q 0
     197 ;
     198MCE6() ; Verify Event/Element: HL7 NEW OERR ORDER
     199 ;
     200 ;
     201 N OCXRES
     202 I $L(OCXDF(37)) S OCXRES(6,37)=OCXDF(37)
     203 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),6)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),6))
     204 Q 0
     205 ;
     206NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     207 ;
     208 ;
     209 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     210 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     211 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     212 ;
     213 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     214 ;
     215 S OCXTIME=(+$H)
     216 S OCXCKSUM=$$CKSUM(OCXMESS)
     217 ;
     218 S OCXTSP=($H*86400)+$P($H,",",2)
     219 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     220 ;
     221 Q:(OCXTSPL>OCXTSP) 0
     222 ;
     223 K OCXDATA
     224 S OCXDATA(OCXDFN,0)=OCXDFN
     225 S OCXDATA("B",OCXDFN,OCXDFN)=""
     226 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     227 ;
     228 S OCXGR="^OCXD(860.7"
     229 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     230 ;
     231 K OCXDATA
     232 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     233 S OCXDATA(OCXRUL,"M")=OCXMESS
     234 S OCXDATA("B",OCXRUL,OCXRUL)=""
     235 S OCXGR=OCXGR_","_OCXDFN_",1"
     236 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     237 ;
     238 K OCXDATA
     239 S OCXDATA(OCXREL,0)=OCXREL
     240 S OCXDATA("B",OCXREL,OCXREL)=""
     241 S OCXGR=OCXGR_","_OCXRUL_",1"
     242 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     243 ;
     244 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     245 .;
     246 .N OCXGR1
     247 .S OCXGR1=OCXGR_","_OCXREL_",1"
     248 .K OCXDATA
     249 .S OCXDATA(OCXELE,0)=OCXELE
     250 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     251 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     252 .S OCXDATA("B",OCXELE,OCXELE)=""
     253 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     254 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     255 .;
     256 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     257 ..N OCXGR2
     258 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     259 ..K OCXDATA
     260 ..S OCXDATA(OCXDFI,0)=OCXDFI
     261 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     262 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     263 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     264 ;
     265 Q 1
     266 ;
     267SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     268 M @ROOT=DATA
     269 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     270 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     271 ;
     272 Q
     273 ;
     274 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m

    r613 r623  
    1 OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R42R1A  ; Verify all Event/Elements of  Rule #42 'ABNORMAL LAB RESULTS'  Relation #1 'ABNORMAL LAB ORDER'
    14         ;  Called from EL23+5^OCXOZ0H.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE23( ----------->  Verify Event/Element: 'HL7 LAB ORDER RESULTS ABNORMAL'
    20         ;
    21         Q:$G(^OCXS(860.2,42,"INACT"))
    22         ;
    23         I $$MCE23 D R42R1B
    24         Q
    25         ;
    26 R42R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #42 'ABNORMAL LAB RESULTS'  Relation #1 'ABNORMAL LAB ORDER'
    27         ;  Called from R42R1A+10.
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ;      Local Extrinsic Functions
    32         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    33         ; NEWRULE( ---------> NEW RULE MESSAGE
    34         ;
    35         Q:$D(OCXRULE("R42R1B"))
    36         ;
    37         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    38         S OCXCMSG=""
    39         S OCXNMSG="Abnormal labs - ["_$$GETDATA(DFN,"23^",96)_"]"
    40         ;
    41         Q:$G(OCXOERR)
    42         ;
    43         ; Send Notification
    44         ;
    45         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    46         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    47         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    48         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    49         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    50         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    51         .S OCXNUM=+$P(OCXORD,U,2)
    52         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    53         S OCXRULE("R42R1B")=""
    54         I $$NEWRULE(DFN,OCXNUM,42,1,14,OCXNMSG) D  I 1
    55         .D:($G(OCXTRACE)<5) EN^ORB3(14,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    56         Q
    57         ;
    58 R42R2A  ; Verify all Event/Elements of  Rule #42 'ABNORMAL LAB RESULTS'  Relation #2 'ABNORMAL LAB TEST'
    59         ;  Called from EL103+5^OCXOZ0H.
    60         ;
    61         Q:$G(OCXOERR)
    62         ;
    63         ;      Local Extrinsic Functions
    64         ; MCE103( ---------->  Verify Event/Element: 'HL7 LAB TEST RESULTS ABNORMAL'
    65         ;
    66         Q:$G(^OCXS(860.2,42,"INACT"))
    67         ;
    68         I $$MCE103 D R42R2B
    69         Q
    70         ;
    71 R42R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #42 'ABNORMAL LAB RESULTS'  Relation #2 'ABNORMAL LAB TEST'
    72         ;  Called from R42R2A+10.
    73         ;
    74         Q:$G(OCXOERR)
    75         ;
    76         ;      Local Extrinsic Functions
    77         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    78         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    79         ; NEWRULE( ---------> NEW RULE MESSAGE
    80         ;
    81         Q:$D(OCXRULE("R42R2B"))
    82         ;
    83         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    84         S OCXCMSG=""
    85         S OCXNMSG="Abnormal lab: "_$$GETDATA(DFN,"103^",114)_" "_$$GETDATA(DFN,"103^",12)_" "_$$INT2DT($$GETDATA(DFN,"103^",13),0)
    86         ;
    87         Q:$G(OCXOERR)
    88         ;
    89         ; Send Notification
    90         ;
    91         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    92         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    93         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    94         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    95         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    96         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    97         .S OCXNUM=+$P(OCXORD,U,2)
    98         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    99         S OCXRULE("R42R2B")=""
    100         I $$NEWRULE(DFN,OCXNUM,42,2,58,OCXNMSG) D  I 1
    101         .D:($G(OCXTRACE)<5) EN^ORB3(58,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    102         Q
    103         ;
    104 R44R1A  ; Verify all Event/Elements of  Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE'  Relation #1 'ELECTRONIC SIGNATURE'
    105         ;  Called from EL48+5^OCXOZ0H.
    106         ;
    107         Q:$G(OCXOERR)
    108         ;
    109         ;      Local Extrinsic Functions
    110         ; MCE48( ----------->  Verify Event/Element: 'ORDER REQUIRES ELECTRONIC SIGNATURE'
    111         ;
    112         Q:$G(^OCXS(860.2,44,"INACT"))
    113         ;
    114         I $$MCE48 D R44R1B^OCXOZ0S
    115         Q
    116         ;
    117 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    118         ;
    119         N CKSUM,PTR,ASC S CKSUM=0
    120         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    121         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    122         Q +CKSUM
    123         ;
    124 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    125         ;
    126         N OCXE,VAL,PC S VAL=""
    127         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    128         Q VAL
    129         ;
    130 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    131         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    132         ;
    133         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    134         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    135         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    136         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    137         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    138         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    139         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    140         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    141         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    142         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    143         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    144         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    145         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    146         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    147         E  S OCXMON=$E(OCXMON+100,2,3)
    148         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    149         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    150         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    151         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    152         Q OCXMON_" "_OCXDAY_","_OCXYR
    153         ;
    154 MCE103()        ; Verify Event/Element: HL7 LAB TEST RESULTS ABNORMAL
    155         ;
    156         ;
    157         N OCXRES
    158         I $L(OCXDF(37)) S OCXRES(103,37)=OCXDF(37)
    159         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),103)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),103))
    160         Q 0
    161         ;
    162 MCE23() ; Verify Event/Element: HL7 LAB ORDER RESULTS ABNORMAL
    163         ;
    164         ;
    165         N OCXRES
    166         I $L(OCXDF(37)) S OCXRES(23,37)=OCXDF(37)
    167         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),23)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),23))
    168         Q 0
    169         ;
    170 MCE48() ; Verify Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE
    171         ;
    172         ;  OCXDF(37) -> PATIENT IEN data field
    173         ;
    174         N OCXRES
    175         S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(48,37)=OCXDF(37)
    176         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),48)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),48))
    177         Q 0
    178         ;
    179 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    180         ;
    181         ;
    182         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    183         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    184         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    185         ;
    186         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    187         ;
    188         S OCXTIME=(+$H)
    189         S OCXCKSUM=$$CKSUM(OCXMESS)
    190         ;
    191         S OCXTSP=($H*86400)+$P($H,",",2)
    192         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    193         ;
    194         Q:(OCXTSPL>OCXTSP) 0
    195         ;
    196         K OCXDATA
    197         S OCXDATA(OCXDFN,0)=OCXDFN
    198         S OCXDATA("B",OCXDFN,OCXDFN)=""
    199         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    200         ;
    201         S OCXGR="^OCXD(860.7"
    202         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    203         ;
    204         K OCXDATA
    205         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    206         S OCXDATA(OCXRUL,"M")=OCXMESS
    207         S OCXDATA("B",OCXRUL,OCXRUL)=""
    208         S OCXGR=OCXGR_","_OCXDFN_",1"
    209         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    210         ;
    211         K OCXDATA
    212         S OCXDATA(OCXREL,0)=OCXREL
    213         S OCXDATA("B",OCXREL,OCXREL)=""
    214         S OCXGR=OCXGR_","_OCXRUL_",1"
    215         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    216         ;
    217         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    218         .;
    219         .N OCXGR1
    220         .S OCXGR1=OCXGR_","_OCXREL_",1"
    221         .K OCXDATA
    222         .S OCXDATA(OCXELE,0)=OCXELE
    223         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    224         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    225         .S OCXDATA("B",OCXELE,OCXELE)=""
    226         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    227         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    228         .;
    229         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    230         ..N OCXGR2
    231         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    232         ..K OCXDATA
    233         ..S OCXDATA(OCXDFI,0)=OCXDFI
    234         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    235         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    236         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    237         ;
    238         Q 1
    239         ;
    240 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    241         M @ROOT=DATA
    242         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    243         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    244         ;
    245         Q
    246         ;
    247         ;
     1OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R42R1A ; Verify all Event/Elements of  Rule #42 'ABNORMAL LAB RESULTS'  Relation #1 'ABNORMAL LAB ORDER'
     14 ;  Called from EL23+5^OCXOZ0H.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE23( ----------->  Verify Event/Element: 'HL7 LAB ORDER RESULTS ABNORMAL'
     20 ;
     21 Q:$G(^OCXS(860.2,42,"INACT"))
     22 ;
     23 I $$MCE23 D R42R1B
     24 Q
     25 ;
     26R42R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #42 'ABNORMAL LAB RESULTS'  Relation #1 'ABNORMAL LAB ORDER'
     27 ;  Called from R42R1A+10.
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ;      Local Extrinsic Functions
     32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     33 ; NEWRULE( ---------> NEW RULE MESSAGE
     34 ;
     35 Q:$D(OCXRULE("R42R1B"))
     36 ;
     37 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     38 S OCXCMSG=""
     39 S OCXNMSG="Abnormal labs - ["_$$GETDATA(DFN,"23^",96)_"]"
     40 ;
     41 Q:$G(OCXOERR)
     42 ;
     43 ; Send Notification
     44 ;
     45 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     46 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     47 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     48 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     49 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     50 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     51 .S OCXNUM=+$P(OCXORD,U,2)
     52 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     53 S OCXRULE("R42R1B")=""
     54 I $$NEWRULE(DFN,OCXNUM,42,1,14,OCXNMSG) D  I 1
     55 .D:($G(OCXTRACE)<5) EN^ORB3(14,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     56 Q
     57 ;
     58R42R2A ; Verify all Event/Elements of  Rule #42 'ABNORMAL LAB RESULTS'  Relation #2 'ABNORMAL LAB TEST'
     59 ;  Called from EL103+5^OCXOZ0H.
     60 ;
     61 Q:$G(OCXOERR)
     62 ;
     63 ;      Local Extrinsic Functions
     64 ; MCE103( ---------->  Verify Event/Element: 'HL7 LAB TEST RESULTS ABNORMAL'
     65 ;
     66 Q:$G(^OCXS(860.2,42,"INACT"))
     67 ;
     68 I $$MCE103 D R42R2B
     69 Q
     70 ;
     71R42R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #42 'ABNORMAL LAB RESULTS'  Relation #2 'ABNORMAL LAB TEST'
     72 ;  Called from R42R2A+10.
     73 ;
     74 Q:$G(OCXOERR)
     75 ;
     76 ;      Local Extrinsic Functions
     77 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     78 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     79 ; NEWRULE( ---------> NEW RULE MESSAGE
     80 ;
     81 Q:$D(OCXRULE("R42R2B"))
     82 ;
     83 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     84 S OCXCMSG=""
     85 S OCXNMSG="Abnormal lab: "_$$GETDATA(DFN,"103^",114)_" "_$$GETDATA(DFN,"103^",12)_" "_$$INT2DT($$GETDATA(DFN,"103^",13),0)
     86 ;
     87 Q:$G(OCXOERR)
     88 ;
     89 ; Send Notification
     90 ;
     91 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     92 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     93 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     94 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     95 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     96 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     97 .S OCXNUM=+$P(OCXORD,U,2)
     98 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     99 S OCXRULE("R42R2B")=""
     100 I $$NEWRULE(DFN,OCXNUM,42,2,58,OCXNMSG) D  I 1
     101 .D:($G(OCXTRACE)<5) EN^ORB3(58,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     102 Q
     103 ;
     104R44R1A ; Verify all Event/Elements of  Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE'  Relation #1 'ELECTRONIC SIGNATURE'
     105 ;  Called from EL48+5^OCXOZ0H.
     106 ;
     107 Q:$G(OCXOERR)
     108 ;
     109 ;      Local Extrinsic Functions
     110 ; MCE48( ----------->  Verify Event/Element: 'ORDER REQUIRES ELECTRONIC SIGNATURE'
     111 ;
     112 Q:$G(^OCXS(860.2,44,"INACT"))
     113 ;
     114 I $$MCE48 D R44R1B^OCXOZ0S
     115 Q
     116 ;
     117CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     118 ;
     119 N CKSUM,PTR,ASC S CKSUM=0
     120 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     121 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     122 Q +CKSUM
     123 ;
     124GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     125 ;
     126 N OCXE,VAL,PC S VAL=""
     127 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     128 Q VAL
     129 ;
     130INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     131 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     132 ;
     133 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     134 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     135 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     136 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     137 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     138 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     139 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     140 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     141 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     142 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     143 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     144 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     145 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     146 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     147 E  S OCXMON=$E(OCXMON+100,2,3)
     148 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     149 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     150 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     151 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     152 Q OCXMON_" "_OCXDAY_","_OCXYR
     153 ;
     154MCE103() ; Verify Event/Element: HL7 LAB TEST RESULTS ABNORMAL
     155 ;
     156 ;
     157 N OCXRES
     158 I $L(OCXDF(37)) S OCXRES(103,37)=OCXDF(37)
     159 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),103)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),103))
     160 Q 0
     161 ;
     162MCE23() ; Verify Event/Element: HL7 LAB ORDER RESULTS ABNORMAL
     163 ;
     164 ;
     165 N OCXRES
     166 I $L(OCXDF(37)) S OCXRES(23,37)=OCXDF(37)
     167 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),23)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),23))
     168 Q 0
     169 ;
     170MCE48() ; Verify Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE
     171 ;
     172 ;  OCXDF(37) -> PATIENT IEN data field
     173 ;
     174 N OCXRES
     175 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(48,37)=OCXDF(37)
     176 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),48)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),48))
     177 Q 0
     178 ;
     179NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     180 ;
     181 ;
     182 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     183 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     184 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     185 ;
     186 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     187 ;
     188 S OCXTIME=(+$H)
     189 S OCXCKSUM=$$CKSUM(OCXMESS)
     190 ;
     191 S OCXTSP=($H*86400)+$P($H,",",2)
     192 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     193 ;
     194 Q:(OCXTSPL>OCXTSP) 0
     195 ;
     196 K OCXDATA
     197 S OCXDATA(OCXDFN,0)=OCXDFN
     198 S OCXDATA("B",OCXDFN,OCXDFN)=""
     199 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     200 ;
     201 S OCXGR="^OCXD(860.7"
     202 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     203 ;
     204 K OCXDATA
     205 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     206 S OCXDATA(OCXRUL,"M")=OCXMESS
     207 S OCXDATA("B",OCXRUL,OCXRUL)=""
     208 S OCXGR=OCXGR_","_OCXDFN_",1"
     209 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     210 ;
     211 K OCXDATA
     212 S OCXDATA(OCXREL,0)=OCXREL
     213 S OCXDATA("B",OCXREL,OCXREL)=""
     214 S OCXGR=OCXGR_","_OCXRUL_",1"
     215 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     216 ;
     217 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     218 .;
     219 .N OCXGR1
     220 .S OCXGR1=OCXGR_","_OCXREL_",1"
     221 .K OCXDATA
     222 .S OCXDATA(OCXELE,0)=OCXELE
     223 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     224 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     225 .S OCXDATA("B",OCXELE,OCXELE)=""
     226 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     227 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     228 .;
     229 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     230 ..N OCXGR2
     231 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     232 ..K OCXDATA
     233 ..S OCXDATA(OCXDFI,0)=OCXDFI
     234 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     235 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     236 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     237 ;
     238 Q 1
     239 ;
     240SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     241 M @ROOT=DATA
     242 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     243 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     244 ;
     245 Q
     246 ;
     247 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m

    r613 r623  
    1 OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R44R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE'  Relation #1 'ELECTRONIC SIGNATURE'
    14         ;  Called from R44R1A+10^OCXOZ0R.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; NEWRULE( ---------> NEW RULE MESSAGE
    20         ;
    21         Q:$D(OCXRULE("R44R1B"))
    22         ;
    23         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    24         S OCXCMSG=""
    25         S OCXNMSG="Order requires electronic signature."
    26         ;
    27         Q:$G(OCXOERR)
    28         ;
    29         ; Send Notification
    30         ;
    31         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    32         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    33         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    34         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    35         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    36         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    37         .S OCXNUM=+$P(OCXORD,U,2)
    38         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    39         S OCXRULE("R44R1B")=""
    40         I $$NEWRULE(DFN,OCXNUM,44,1,12,OCXNMSG) D  I 1
    41         .D:($G(OCXTRACE)<5) EN^ORB3(12,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    42         Q
    43         ;
    44 R48R1A  ; Verify all Event/Elements of  Rule #48 'SITE FLAGGED ORDER'  Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT'
    45         ;  Called from EL58+5^OCXOZ0H, and EL127+5^OCXOZ0H.
    46         ;
    47         Q:$G(OCXOERR)
    48         ;
    49         ;      Local Extrinsic Functions
    50         ; MCE127( ---------->  Verify Event/Element: 'INPATIENT'
    51         ; MCE58( ----------->  Verify Event/Element: 'NEW SITE FLAGGED ORDER'
    52         ;
    53         Q:$G(^OCXS(860.2,48,"INACT"))
    54         ;
    55         I $$MCE58 D
    56         .I $$MCE127 D R48R1B
    57         Q
    58         ;
    59 R48R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #48 'SITE FLAGGED ORDER'  Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT'
    60         ;  Called from R48R1A+12.
    61         ;
    62         Q:$G(OCXOERR)
    63         ;
    64         ;      Local Extrinsic Functions
    65         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    66         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    67         ; NEWRULE( ---------> NEW RULE MESSAGE
    68         ;
    69         Q:$D(OCXRULE("R48R1B"))
    70         ;
    71         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    72         S OCXCMSG=""
    73         S OCXNMSG="["_$$GETDATA(DFN,"58^127",147)_"] Order placed: "_$$GETDATA(DFN,"58^127",96)_" "_$$INT2DT($$GETDATA(DFN,"58^127",9),0)_"."
    74         ;
    75         Q:$G(OCXOERR)
    76         ;
    77         ; Send Notification
    78         ;
    79         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    80         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    81         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    82         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    83         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    84         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    85         .S OCXNUM=+$P(OCXORD,U,2)
    86         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    87         S OCXRULE("R48R1B")=""
    88         I $$NEWRULE(DFN,OCXNUM,48,1,41,OCXNMSG) D  I 1
    89         .D:($G(OCXTRACE)<5) EN^ORB3(41,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    90         Q
    91         ;
    92 R48R2A  ; Verify all Event/Elements of  Rule #48 'SITE FLAGGED ORDER'  Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT'
    93         ;  Called from EL58+6^OCXOZ0H, and EL128+5^OCXOZ0H.
    94         ;
    95         Q:$G(OCXOERR)
    96         ;
    97         ;      Local Extrinsic Functions
    98         ; MCE128( ---------->  Verify Event/Element: 'OUTPATIENT'
    99         ; MCE58( ----------->  Verify Event/Element: 'NEW SITE FLAGGED ORDER'
    100         ;
    101         Q:$G(^OCXS(860.2,48,"INACT"))
    102         ;
    103         I $$MCE58 D
    104         .I $$MCE128 D R48R2B^OCXOZ0T
    105         Q
    106         ;
    107 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    108         ;
    109         N CKSUM,PTR,ASC S CKSUM=0
    110         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    111         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    112         Q +CKSUM
    113         ;
    114 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    115         ;
    116         N OCXE,VAL,PC S VAL=""
    117         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    118         Q VAL
    119         ;
    120 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    121         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    122         ;
    123         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    124         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    125         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    126         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    127         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    128         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    129         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    130         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    131         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    132         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    133         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    134         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    135         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    136         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    137         E  S OCXMON=$E(OCXMON+100,2,3)
    138         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    139         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    140         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    141         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    142         Q OCXMON_" "_OCXDAY_","_OCXYR
    143         ;
    144 MCE127()        ; Verify Event/Element: INPATIENT
    145         ;
    146         ;
    147         N OCXRES
    148         I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37)
    149         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127))
    150         Q 0
    151         ;
    152 MCE128()        ; Verify Event/Element: OUTPATIENT
    153         ;
    154         ;
    155         N OCXRES
    156         I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37)
    157         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128))
    158         Q 0
    159         ;
    160 MCE58() ; Verify Event/Element: NEW SITE FLAGGED ORDER
    161         ;
    162         ;
    163         N OCXRES
    164         I $L(OCXDF(37)) S OCXRES(58,37)=OCXDF(37)
    165         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),58)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),58))
    166         Q 0
    167         ;
    168 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    169         ;
    170         ;
    171         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    172         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    173         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    174         ;
    175         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    176         ;
    177         S OCXTIME=(+$H)
    178         S OCXCKSUM=$$CKSUM(OCXMESS)
    179         ;
    180         S OCXTSP=($H*86400)+$P($H,",",2)
    181         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    182         ;
    183         Q:(OCXTSPL>OCXTSP) 0
    184         ;
    185         K OCXDATA
    186         S OCXDATA(OCXDFN,0)=OCXDFN
    187         S OCXDATA("B",OCXDFN,OCXDFN)=""
    188         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    189         ;
    190         S OCXGR="^OCXD(860.7"
    191         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    192         ;
    193         K OCXDATA
    194         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    195         S OCXDATA(OCXRUL,"M")=OCXMESS
    196         S OCXDATA("B",OCXRUL,OCXRUL)=""
    197         S OCXGR=OCXGR_","_OCXDFN_",1"
    198         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    199         ;
    200         K OCXDATA
    201         S OCXDATA(OCXREL,0)=OCXREL
    202         S OCXDATA("B",OCXREL,OCXREL)=""
    203         S OCXGR=OCXGR_","_OCXRUL_",1"
    204         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    205         ;
    206         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    207         .;
    208         .N OCXGR1
    209         .S OCXGR1=OCXGR_","_OCXREL_",1"
    210         .K OCXDATA
    211         .S OCXDATA(OCXELE,0)=OCXELE
    212         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    213         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    214         .S OCXDATA("B",OCXELE,OCXELE)=""
    215         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    216         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    217         .;
    218         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    219         ..N OCXGR2
    220         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    221         ..K OCXDATA
    222         ..S OCXDATA(OCXDFI,0)=OCXDFI
    223         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    224         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    225         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    226         ;
    227         Q 1
    228         ;
    229 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    230         M @ROOT=DATA
    231         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    232         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    233         ;
    234         Q
    235         ;
    236         ;
     1OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R44R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE'  Relation #1 'ELECTRONIC SIGNATURE'
     14 ;  Called from R44R1A+10^OCXOZ0R.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; NEWRULE( ---------> NEW RULE MESSAGE
     20 ;
     21 Q:$D(OCXRULE("R44R1B"))
     22 ;
     23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     24 S OCXCMSG=""
     25 S OCXNMSG="Order requires electronic signature."
     26 ;
     27 Q:$G(OCXOERR)
     28 ;
     29 ; Send Notification
     30 ;
     31 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     32 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     33 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     34 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     35 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     36 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     37 .S OCXNUM=+$P(OCXORD,U,2)
     38 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     39 S OCXRULE("R44R1B")=""
     40 I $$NEWRULE(DFN,OCXNUM,44,1,12,OCXNMSG) D  I 1
     41 .D:($G(OCXTRACE)<5) EN^ORB3(12,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     42 Q
     43 ;
     44R48R1A ; Verify all Event/Elements of  Rule #48 'SITE FLAGGED ORDER'  Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT'
     45 ;  Called from EL58+5^OCXOZ0H, and EL127+5^OCXOZ0H.
     46 ;
     47 Q:$G(OCXOERR)
     48 ;
     49 ;      Local Extrinsic Functions
     50 ; MCE127( ---------->  Verify Event/Element: 'INPATIENT'
     51 ; MCE58( ----------->  Verify Event/Element: 'NEW SITE FLAGGED ORDER'
     52 ;
     53 Q:$G(^OCXS(860.2,48,"INACT"))
     54 ;
     55 I $$MCE58 D
     56 .I $$MCE127 D R48R1B
     57 Q
     58 ;
     59R48R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #48 'SITE FLAGGED ORDER'  Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT'
     60 ;  Called from R48R1A+12.
     61 ;
     62 Q:$G(OCXOERR)
     63 ;
     64 ;      Local Extrinsic Functions
     65 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     66 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     67 ; NEWRULE( ---------> NEW RULE MESSAGE
     68 ;
     69 Q:$D(OCXRULE("R48R1B"))
     70 ;
     71 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     72 S OCXCMSG=""
     73 S OCXNMSG="["_$$GETDATA(DFN,"58^127",147)_"] Order placed: "_$$GETDATA(DFN,"58^127",96)_" "_$$INT2DT($$GETDATA(DFN,"58^127",9),0)_"."
     74 ;
     75 Q:$G(OCXOERR)
     76 ;
     77 ; Send Notification
     78 ;
     79 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     80 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     81 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     82 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     83 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     84 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     85 .S OCXNUM=+$P(OCXORD,U,2)
     86 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     87 S OCXRULE("R48R1B")=""
     88 I $$NEWRULE(DFN,OCXNUM,48,1,41,OCXNMSG) D  I 1
     89 .D:($G(OCXTRACE)<5) EN^ORB3(41,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     90 Q
     91 ;
     92R48R2A ; Verify all Event/Elements of  Rule #48 'SITE FLAGGED ORDER'  Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT'
     93 ;  Called from EL58+6^OCXOZ0H, and EL128+5^OCXOZ0H.
     94 ;
     95 Q:$G(OCXOERR)
     96 ;
     97 ;      Local Extrinsic Functions
     98 ; MCE128( ---------->  Verify Event/Element: 'OUTPATIENT'
     99 ; MCE58( ----------->  Verify Event/Element: 'NEW SITE FLAGGED ORDER'
     100 ;
     101 Q:$G(^OCXS(860.2,48,"INACT"))
     102 ;
     103 I $$MCE58 D
     104 .I $$MCE128 D R48R2B^OCXOZ0T
     105 Q
     106 ;
     107CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     108 ;
     109 N CKSUM,PTR,ASC S CKSUM=0
     110 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     111 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     112 Q +CKSUM
     113 ;
     114GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     115 ;
     116 N OCXE,VAL,PC S VAL=""
     117 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     118 Q VAL
     119 ;
     120INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     121 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     122 ;
     123 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     124 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     125 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     126 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     127 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     128 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     129 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     130 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     131 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     132 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     133 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     134 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     135 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     136 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     137 E  S OCXMON=$E(OCXMON+100,2,3)
     138 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     139 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     140 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     141 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     142 Q OCXMON_" "_OCXDAY_","_OCXYR
     143 ;
     144MCE127() ; Verify Event/Element: INPATIENT
     145 ;
     146 ;
     147 N OCXRES
     148 I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37)
     149 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127))
     150 Q 0
     151 ;
     152MCE128() ; Verify Event/Element: OUTPATIENT
     153 ;
     154 ;
     155 N OCXRES
     156 I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37)
     157 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128))
     158 Q 0
     159 ;
     160MCE58() ; Verify Event/Element: NEW SITE FLAGGED ORDER
     161 ;
     162 ;
     163 N OCXRES
     164 I $L(OCXDF(37)) S OCXRES(58,37)=OCXDF(37)
     165 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),58)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),58))
     166 Q 0
     167 ;
     168NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     169 ;
     170 ;
     171 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     172 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     173 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     174 ;
     175 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     176 ;
     177 S OCXTIME=(+$H)
     178 S OCXCKSUM=$$CKSUM(OCXMESS)
     179 ;
     180 S OCXTSP=($H*86400)+$P($H,",",2)
     181 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     182 ;
     183 Q:(OCXTSPL>OCXTSP) 0
     184 ;
     185 K OCXDATA
     186 S OCXDATA(OCXDFN,0)=OCXDFN
     187 S OCXDATA("B",OCXDFN,OCXDFN)=""
     188 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     189 ;
     190 S OCXGR="^OCXD(860.7"
     191 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     192 ;
     193 K OCXDATA
     194 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     195 S OCXDATA(OCXRUL,"M")=OCXMESS
     196 S OCXDATA("B",OCXRUL,OCXRUL)=""
     197 S OCXGR=OCXGR_","_OCXDFN_",1"
     198 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     199 ;
     200 K OCXDATA
     201 S OCXDATA(OCXREL,0)=OCXREL
     202 S OCXDATA("B",OCXREL,OCXREL)=""
     203 S OCXGR=OCXGR_","_OCXRUL_",1"
     204 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     205 ;
     206 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     207 .;
     208 .N OCXGR1
     209 .S OCXGR1=OCXGR_","_OCXREL_",1"
     210 .K OCXDATA
     211 .S OCXDATA(OCXELE,0)=OCXELE
     212 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     213 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     214 .S OCXDATA("B",OCXELE,OCXELE)=""
     215 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     216 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     217 .;
     218 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     219 ..N OCXGR2
     220 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     221 ..K OCXDATA
     222 ..S OCXDATA(OCXDFI,0)=OCXDFI
     223 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     224 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     225 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     226 ;
     227 Q 1
     228 ;
     229SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     230 M @ROOT=DATA
     231 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     232 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     233 ;
     234 Q
     235 ;
     236 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m

    r613 r623  
    1 OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R48R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #48 'SITE FLAGGED ORDER'  Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT'
    14         ;  Called from R48R2A+12^OCXOZ0S.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    21         ; NEWRULE( ---------> NEW RULE MESSAGE
    22         ;
    23         Q:$D(OCXRULE("R48R2B"))
    24         ;
    25         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    26         S OCXCMSG=""
    27         S OCXNMSG="["_$$GETDATA(DFN,"58^128",147)_"] Order placed: "_$$GETDATA(DFN,"58^128",96)_" "_$$INT2DT($$GETDATA(DFN,"58^128",9),0)_"."
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ; Send Notification
    32         ;
    33         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    34         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    35         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    36         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    37         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    38         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    39         .S OCXNUM=+$P(OCXORD,U,2)
    40         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    41         S OCXRULE("R48R2B")=""
    42         I $$NEWRULE(DFN,OCXNUM,48,2,61,OCXNMSG) D  I 1
    43         .D:($G(OCXTRACE)<5) EN^ORB3(61,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    44         Q
    45         ;
    46 R49R1A  ; Verify all Event/Elements of  Rule #49 'SITE FLAGGED RESULT'  Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...'
    47         ;  Called from EL127+6^OCXOZ0H, and EL59+5^OCXOZ0H, and EL102+5^OCXOZ0H, and EL109+5^OCXOZ0H.
    48         ;
    49         Q:$G(OCXOERR)
    50         ;
    51         ;      Local Extrinsic Functions
    52         ; MCE102( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT'
    53         ; MCE109( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT'
    54         ; MCE127( ---------->  Verify Event/Element: 'INPATIENT'
    55         ; MCE59( ----------->  Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT'
    56         ;
    57         Q:$G(^OCXS(860.2,49,"INACT"))
    58         ;
    59         I $$MCE127 D
    60         .I $$MCE59 D R49R1B
    61         .I $$MCE102 D R49R1B
    62         .I $$MCE109 D R49R1B
    63         Q
    64         ;
    65 R49R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #49 'SITE FLAGGED RESULT'  Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...'
    66         ;  Called from R49R1A+14.
    67         ;
    68         Q:$G(OCXOERR)
    69         ;
    70         ;      Local Extrinsic Functions
    71         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    72         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    73         ; NEWRULE( ---------> NEW RULE MESSAGE
    74         ;
    75         Q:$D(OCXRULE("R49R1B"))
    76         ;
    77         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    78         S OCXCMSG=""
    79         S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^127",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^127",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^127",9),0)_" "
    80         ;
    81         Q:$G(OCXOERR)
    82         ;
    83         ; Send Notification
    84         ;
    85         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    86         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    87         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    88         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    89         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    90         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    91         .S OCXNUM=+$P(OCXORD,U,2)
    92         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    93         S OCXRULE("R49R1B")=""
    94         I $$NEWRULE(DFN,OCXNUM,49,1,32,OCXNMSG) D  I 1
    95         .D:($G(OCXTRACE)<5) EN^ORB3(32,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    96         Q
    97         ;
    98 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    99         ;
    100         N CKSUM,PTR,ASC S CKSUM=0
    101         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    102         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    103         Q +CKSUM
    104         ;
    105 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    106         ;
    107         N OCXE,VAL,PC S VAL=""
    108         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    109         Q VAL
    110         ;
    111 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    112         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    113         ;
    114         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    115         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    116         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    117         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    118         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    119         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    120         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    121         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    122         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    123         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    124         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    125         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    126         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    127         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    128         E  S OCXMON=$E(OCXMON+100,2,3)
    129         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    130         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    131         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    132         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    133         Q OCXMON_" "_OCXDAY_","_OCXYR
    134         ;
    135 MCE102()        ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT
    136         ;
    137         ;
    138         N OCXRES
    139         I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37)
    140         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102))
    141         Q 0
    142         ;
    143 MCE109()        ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT
    144         ;
    145         ;
    146         N OCXRES
    147         I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37)
    148         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109))
    149         Q 0
    150         ;
    151 MCE127()        ; Verify Event/Element: INPATIENT
    152         ;
    153         ;
    154         N OCXRES
    155         I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37)
    156         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127))
    157         Q 0
    158         ;
    159 MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT
    160         ;
    161         ;
    162         N OCXRES
    163         I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37)
    164         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59))
    165         Q 0
    166         ;
    167 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    168         ;
    169         ;
    170         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    171         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    172         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    173         ;
    174         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    175         ;
    176         S OCXTIME=(+$H)
    177         S OCXCKSUM=$$CKSUM(OCXMESS)
    178         ;
    179         S OCXTSP=($H*86400)+$P($H,",",2)
    180         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    181         ;
    182         Q:(OCXTSPL>OCXTSP) 0
    183         ;
    184         K OCXDATA
    185         S OCXDATA(OCXDFN,0)=OCXDFN
    186         S OCXDATA("B",OCXDFN,OCXDFN)=""
    187         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    188         ;
    189         S OCXGR="^OCXD(860.7"
    190         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    191         ;
    192         K OCXDATA
    193         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    194         S OCXDATA(OCXRUL,"M")=OCXMESS
    195         S OCXDATA("B",OCXRUL,OCXRUL)=""
    196         S OCXGR=OCXGR_","_OCXDFN_",1"
    197         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    198         ;
    199         K OCXDATA
    200         S OCXDATA(OCXREL,0)=OCXREL
    201         S OCXDATA("B",OCXREL,OCXREL)=""
    202         S OCXGR=OCXGR_","_OCXRUL_",1"
    203         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    204         ;
    205         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    206         .;
    207         .N OCXGR1
    208         .S OCXGR1=OCXGR_","_OCXREL_",1"
    209         .K OCXDATA
    210         .S OCXDATA(OCXELE,0)=OCXELE
    211         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    212         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    213         .S OCXDATA("B",OCXELE,OCXELE)=""
    214         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    215         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    216         .;
    217         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    218         ..N OCXGR2
    219         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    220         ..K OCXDATA
    221         ..S OCXDATA(OCXDFI,0)=OCXDFI
    222         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    223         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    224         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    225         ;
    226         Q 1
    227         ;
    228 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    229         M @ROOT=DATA
    230         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    231         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    232         ;
    233         Q
    234         ;
    235         ;
     1OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R48R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #48 'SITE FLAGGED ORDER'  Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT'
     14 ;  Called from R48R2A+12^OCXOZ0S.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     21 ; NEWRULE( ---------> NEW RULE MESSAGE
     22 ;
     23 Q:$D(OCXRULE("R48R2B"))
     24 ;
     25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     26 S OCXCMSG=""
     27 S OCXNMSG="["_$$GETDATA(DFN,"58^128",147)_"] Order placed: "_$$GETDATA(DFN,"58^128",96)_" "_$$INT2DT($$GETDATA(DFN,"58^128",9),0)_"."
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ; Send Notification
     32 ;
     33 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     39 .S OCXNUM=+$P(OCXORD,U,2)
     40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     41 S OCXRULE("R48R2B")=""
     42 I $$NEWRULE(DFN,OCXNUM,48,2,61,OCXNMSG) D  I 1
     43 .D:($G(OCXTRACE)<5) EN^ORB3(61,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     44 Q
     45 ;
     46R49R1A ; Verify all Event/Elements of  Rule #49 'SITE FLAGGED RESULT'  Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...'
     47 ;  Called from EL127+6^OCXOZ0H, and EL59+5^OCXOZ0H, and EL102+5^OCXOZ0H, and EL109+5^OCXOZ0H.
     48 ;
     49 Q:$G(OCXOERR)
     50 ;
     51 ;      Local Extrinsic Functions
     52 ; MCE102( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT'
     53 ; MCE109( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT'
     54 ; MCE127( ---------->  Verify Event/Element: 'INPATIENT'
     55 ; MCE59( ----------->  Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT'
     56 ;
     57 Q:$G(^OCXS(860.2,49,"INACT"))
     58 ;
     59 I $$MCE127 D
     60 .I $$MCE59 D R49R1B
     61 .I $$MCE102 D R49R1B
     62 .I $$MCE109 D R49R1B
     63 Q
     64 ;
     65R49R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #49 'SITE FLAGGED RESULT'  Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...'
     66 ;  Called from R49R1A+14.
     67 ;
     68 Q:$G(OCXOERR)
     69 ;
     70 ;      Local Extrinsic Functions
     71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     72 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     73 ; NEWRULE( ---------> NEW RULE MESSAGE
     74 ;
     75 Q:$D(OCXRULE("R49R1B"))
     76 ;
     77 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     78 S OCXCMSG=""
     79 S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^127",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^127",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^127",9),0)_" "
     80 ;
     81 Q:$G(OCXOERR)
     82 ;
     83 ; Send Notification
     84 ;
     85 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     86 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     87 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     88 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     89 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     90 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     91 .S OCXNUM=+$P(OCXORD,U,2)
     92 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     93 S OCXRULE("R49R1B")=""
     94 I $$NEWRULE(DFN,OCXNUM,49,1,32,OCXNMSG) D  I 1
     95 .D:($G(OCXTRACE)<5) EN^ORB3(32,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     96 Q
     97 ;
     98CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     99 ;
     100 N CKSUM,PTR,ASC S CKSUM=0
     101 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     102 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     103 Q +CKSUM
     104 ;
     105GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     106 ;
     107 N OCXE,VAL,PC S VAL=""
     108 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     109 Q VAL
     110 ;
     111INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     112 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     113 ;
     114 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     115 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     116 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     117 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     118 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     119 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     120 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     121 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     122 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     123 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     124 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     125 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     126 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     127 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     128 E  S OCXMON=$E(OCXMON+100,2,3)
     129 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     130 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     131 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     132 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     133 Q OCXMON_" "_OCXDAY_","_OCXYR
     134 ;
     135MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT
     136 ;
     137 ;
     138 N OCXRES
     139 I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37)
     140 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102))
     141 Q 0
     142 ;
     143MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT
     144 ;
     145 ;
     146 N OCXRES
     147 I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37)
     148 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109))
     149 Q 0
     150 ;
     151MCE127() ; Verify Event/Element: INPATIENT
     152 ;
     153 ;
     154 N OCXRES
     155 I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37)
     156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127))
     157 Q 0
     158 ;
     159MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT
     160 ;
     161 ;
     162 N OCXRES
     163 I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37)
     164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59))
     165 Q 0
     166 ;
     167NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     168 ;
     169 ;
     170 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     171 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     172 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     173 ;
     174 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     175 ;
     176 S OCXTIME=(+$H)
     177 S OCXCKSUM=$$CKSUM(OCXMESS)
     178 ;
     179 S OCXTSP=($H*86400)+$P($H,",",2)
     180 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     181 ;
     182 Q:(OCXTSPL>OCXTSP) 0
     183 ;
     184 K OCXDATA
     185 S OCXDATA(OCXDFN,0)=OCXDFN
     186 S OCXDATA("B",OCXDFN,OCXDFN)=""
     187 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     188 ;
     189 S OCXGR="^OCXD(860.7"
     190 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     191 ;
     192 K OCXDATA
     193 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     194 S OCXDATA(OCXRUL,"M")=OCXMESS
     195 S OCXDATA("B",OCXRUL,OCXRUL)=""
     196 S OCXGR=OCXGR_","_OCXDFN_",1"
     197 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     198 ;
     199 K OCXDATA
     200 S OCXDATA(OCXREL,0)=OCXREL
     201 S OCXDATA("B",OCXREL,OCXREL)=""
     202 S OCXGR=OCXGR_","_OCXRUL_",1"
     203 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     204 ;
     205 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     206 .;
     207 .N OCXGR1
     208 .S OCXGR1=OCXGR_","_OCXREL_",1"
     209 .K OCXDATA
     210 .S OCXDATA(OCXELE,0)=OCXELE
     211 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     212 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     213 .S OCXDATA("B",OCXELE,OCXELE)=""
     214 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     215 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     216 .;
     217 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     218 ..N OCXGR2
     219 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     220 ..K OCXDATA
     221 ..S OCXDATA(OCXDFI,0)=OCXDFI
     222 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     223 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     224 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     225 ;
     226 Q 1
     227 ;
     228SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     229 M @ROOT=DATA
     230 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     231 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     232 ;
     233 Q
     234 ;
     235 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m

    r613 r623  
    1 OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R49R2A  ; Verify all Event/Elements of  Rule #49 'SITE FLAGGED RESULT'  Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...'
    14         ;  Called from EL128+6^OCXOZ0H, and EL59+6^OCXOZ0H, and EL102+6^OCXOZ0H, and EL109+6^OCXOZ0H.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE102( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT'
    20         ; MCE109( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT'
    21         ; MCE128( ---------->  Verify Event/Element: 'OUTPATIENT'
    22         ; MCE59( ----------->  Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT'
    23         ;
    24         Q:$G(^OCXS(860.2,49,"INACT"))
    25         ;
    26         I $$MCE128 D
    27         .I $$MCE59 D R49R2B
    28         .I $$MCE102 D R49R2B
    29         .I $$MCE109 D R49R2B
    30         Q
    31         ;
    32 R49R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #49 'SITE FLAGGED RESULT'  Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...'
    33         ;  Called from R49R2A+14.
    34         ;
    35         Q:$G(OCXOERR)
    36         ;
    37         ;      Local Extrinsic Functions
    38         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    39         ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
    40         ; NEWRULE( ---------> NEW RULE MESSAGE
    41         ;
    42         Q:$D(OCXRULE("R49R2B"))
    43         ;
    44         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    45         S OCXCMSG=""
    46         S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^128",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^128",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^128",9),0)_" "
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ; Send Notification
    51         ;
    52         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    53         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    54         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    55         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    56         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    57         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    58         .S OCXNUM=+$P(OCXORD,U,2)
    59         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    60         S OCXRULE("R49R2B")=""
    61         I $$NEWRULE(DFN,OCXNUM,49,2,60,OCXNMSG) D  I 1
    62         .D:($G(OCXTRACE)<5) EN^ORB3(60,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    63         Q
    64         ;
    65 R50R1A  ; Verify all Event/Elements of  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS'
    66         ;  Called from EL129+5^OCXOZ0H, and EL130+5^OCXOZ0H.
    67         ;
    68         Q:$G(OCXOERR)
    69         ;
    70         ;      Local Extrinsic Functions
    71         ; MCE129( ---------->  Verify Event/Element: 'ABNORMAL RENAL RESULTS'
    72         ; MCE130( ---------->  Verify Event/Element: 'CONTRAST MEDIA ORDER'
    73         ;
    74         Q:$G(^OCXS(860.2,50,"INACT"))
    75         ;
    76         I $$MCE130 D
    77         .I $$MCE129 D R50R1B^OCXOZ0V
    78         Q
    79         ;
    80 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    81         ;
    82         N CKSUM,PTR,ASC S CKSUM=0
    83         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    84         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    85         Q +CKSUM
    86         ;
    87 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    88         ;
    89         N OCXE,VAL,PC S VAL=""
    90         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    91         Q VAL
    92         ;
    93 INT2DT(OCXDT,OCXF)      ;      This Local Extrinsic Function converts an OCX internal format
    94         ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
    95         ;
    96         Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
    97         N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
    98         S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
    99         S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    100         S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
    101         S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
    102         S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
    103         S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
    104         S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
    105         S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
    106         S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
    107         F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
    108         S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
    109         I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
    110         E  S OCXMON=$E(OCXMON+100,2,3)
    111         S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
    112         I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
    113         Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
    114         Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
    115         Q OCXMON_" "_OCXDAY_","_OCXYR
    116         ;
    117 MCE102()        ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT
    118         ;
    119         ;
    120         N OCXRES
    121         I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37)
    122         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102))
    123         Q 0
    124         ;
    125 MCE109()        ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT
    126         ;
    127         ;
    128         N OCXRES
    129         I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37)
    130         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109))
    131         Q 0
    132         ;
    133 MCE128()        ; Verify Event/Element: OUTPATIENT
    134         ;
    135         ;
    136         N OCXRES
    137         I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37)
    138         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128))
    139         Q 0
    140         ;
    141 MCE129()        ; Verify Event/Element: ABNORMAL RENAL RESULTS
    142         ;
    143         ;  OCXDF(37) -> PATIENT IEN data field
    144         ;
    145         N OCXRES
    146         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(129,37)=OCXDF(37)
    147         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),129)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),129))
    148         Q 0
    149         ;
    150 MCE130()        ; Verify Event/Element: CONTRAST MEDIA ORDER
    151         ;
    152         ;  OCXDF(37) -> PATIENT IEN data field
    153         ;
    154         N OCXRES
    155         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37)
    156         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130))
    157         Q 0
    158         ;
    159 MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT
    160         ;
    161         ;
    162         N OCXRES
    163         I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37)
    164         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59))
    165         Q 0
    166         ;
    167 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    168         ;
    169         ;
    170         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    171         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    172         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    173         ;
    174         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    175         ;
    176         S OCXTIME=(+$H)
    177         S OCXCKSUM=$$CKSUM(OCXMESS)
    178         ;
    179         S OCXTSP=($H*86400)+$P($H,",",2)
    180         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    181         ;
    182         Q:(OCXTSPL>OCXTSP) 0
    183         ;
    184         K OCXDATA
    185         S OCXDATA(OCXDFN,0)=OCXDFN
    186         S OCXDATA("B",OCXDFN,OCXDFN)=""
    187         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    188         ;
    189         S OCXGR="^OCXD(860.7"
    190         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    191         ;
    192         K OCXDATA
    193         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    194         S OCXDATA(OCXRUL,"M")=OCXMESS
    195         S OCXDATA("B",OCXRUL,OCXRUL)=""
    196         S OCXGR=OCXGR_","_OCXDFN_",1"
    197         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    198         ;
    199         K OCXDATA
    200         S OCXDATA(OCXREL,0)=OCXREL
    201         S OCXDATA("B",OCXREL,OCXREL)=""
    202         S OCXGR=OCXGR_","_OCXRUL_",1"
    203         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    204         ;
    205         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    206         .;
    207         .N OCXGR1
    208         .S OCXGR1=OCXGR_","_OCXREL_",1"
    209         .K OCXDATA
    210         .S OCXDATA(OCXELE,0)=OCXELE
    211         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    212         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    213         .S OCXDATA("B",OCXELE,OCXELE)=""
    214         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    215         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    216         .;
    217         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    218         ..N OCXGR2
    219         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    220         ..K OCXDATA
    221         ..S OCXDATA(OCXDFI,0)=OCXDFI
    222         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    223         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    224         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    225         ;
    226         Q 1
    227         ;
    228 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    229         M @ROOT=DATA
    230         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    231         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    232         ;
    233         Q
    234         ;
    235         ;
     1OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R49R2A ; Verify all Event/Elements of  Rule #49 'SITE FLAGGED RESULT'  Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...'
     14 ;  Called from EL128+6^OCXOZ0H, and EL59+6^OCXOZ0H, and EL102+6^OCXOZ0H, and EL109+6^OCXOZ0H.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE102( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT'
     20 ; MCE109( ---------->  Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT'
     21 ; MCE128( ---------->  Verify Event/Element: 'OUTPATIENT'
     22 ; MCE59( ----------->  Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT'
     23 ;
     24 Q:$G(^OCXS(860.2,49,"INACT"))
     25 ;
     26 I $$MCE128 D
     27 .I $$MCE59 D R49R2B
     28 .I $$MCE102 D R49R2B
     29 .I $$MCE109 D R49R2B
     30 Q
     31 ;
     32R49R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #49 'SITE FLAGGED RESULT'  Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...'
     33 ;  Called from R49R2A+14.
     34 ;
     35 Q:$G(OCXOERR)
     36 ;
     37 ;      Local Extrinsic Functions
     38 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     39 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT
     40 ; NEWRULE( ---------> NEW RULE MESSAGE
     41 ;
     42 Q:$D(OCXRULE("R49R2B"))
     43 ;
     44 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     45 S OCXCMSG=""
     46 S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^128",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^128",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^128",9),0)_" "
     47 ;
     48 Q:$G(OCXOERR)
     49 ;
     50 ; Send Notification
     51 ;
     52 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     53 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     54 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     55 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     56 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     57 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     58 .S OCXNUM=+$P(OCXORD,U,2)
     59 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     60 S OCXRULE("R49R2B")=""
     61 I $$NEWRULE(DFN,OCXNUM,49,2,60,OCXNMSG) D  I 1
     62 .D:($G(OCXTRACE)<5) EN^ORB3(60,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     63 Q
     64 ;
     65R50R1A ; Verify all Event/Elements of  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS'
     66 ;  Called from EL129+5^OCXOZ0H, and EL130+5^OCXOZ0H.
     67 ;
     68 Q:$G(OCXOERR)
     69 ;
     70 ;      Local Extrinsic Functions
     71 ; MCE129( ---------->  Verify Event/Element: 'ABNORMAL RENAL RESULTS'
     72 ; MCE130( ---------->  Verify Event/Element: 'CONTRAST MEDIA ORDER'
     73 ;
     74 Q:$G(^OCXS(860.2,50,"INACT"))
     75 ;
     76 I $$MCE130 D
     77 .I $$MCE129 D R50R1B^OCXOZ0V
     78 Q
     79 ;
     80CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     81 ;
     82 N CKSUM,PTR,ASC S CKSUM=0
     83 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     84 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     85 Q +CKSUM
     86 ;
     87GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     88 ;
     89 N OCXE,VAL,PC S VAL=""
     90 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     91 Q VAL
     92 ;
     93INT2DT(OCXDT,OCXF) ;      This Local Extrinsic Function converts an OCX internal format
     94 ; date into an Externl Format (Human Readable) date.   'OCXF=SHORT FORMAT OCXF=LONG FORMAT
     95 ;
     96 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF)
     97 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR
     98 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)=""
     99 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     100 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60
     101 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24
     102 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365)
     103 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461
     104 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR
     105 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365"
     106 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366"
     107 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON))
     108 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1
     109 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON)
     110 E  S OCXMON=$E(OCXMON+100,2,3)
     111 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM")
     112 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12
     113 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4))
     114 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP
     115 Q OCXMON_" "_OCXDAY_","_OCXYR
     116 ;
     117MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT
     118 ;
     119 ;
     120 N OCXRES
     121 I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37)
     122 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102))
     123 Q 0
     124 ;
     125MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT
     126 ;
     127 ;
     128 N OCXRES
     129 I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37)
     130 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109))
     131 Q 0
     132 ;
     133MCE128() ; Verify Event/Element: OUTPATIENT
     134 ;
     135 ;
     136 N OCXRES
     137 I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37)
     138 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128))
     139 Q 0
     140 ;
     141MCE129() ; Verify Event/Element: ABNORMAL RENAL RESULTS
     142 ;
     143 ;  OCXDF(37) -> PATIENT IEN data field
     144 ;
     145 N OCXRES
     146 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(129,37)=OCXDF(37)
     147 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),129)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),129))
     148 Q 0
     149 ;
     150MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER
     151 ;
     152 ;  OCXDF(37) -> PATIENT IEN data field
     153 ;
     154 N OCXRES
     155 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37)
     156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130))
     157 Q 0
     158 ;
     159MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT
     160 ;
     161 ;
     162 N OCXRES
     163 I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37)
     164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59))
     165 Q 0
     166 ;
     167NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     168 ;
     169 ;
     170 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     171 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     172 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     173 ;
     174 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     175 ;
     176 S OCXTIME=(+$H)
     177 S OCXCKSUM=$$CKSUM(OCXMESS)
     178 ;
     179 S OCXTSP=($H*86400)+$P($H,",",2)
     180 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     181 ;
     182 Q:(OCXTSPL>OCXTSP) 0
     183 ;
     184 K OCXDATA
     185 S OCXDATA(OCXDFN,0)=OCXDFN
     186 S OCXDATA("B",OCXDFN,OCXDFN)=""
     187 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     188 ;
     189 S OCXGR="^OCXD(860.7"
     190 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     191 ;
     192 K OCXDATA
     193 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     194 S OCXDATA(OCXRUL,"M")=OCXMESS
     195 S OCXDATA("B",OCXRUL,OCXRUL)=""
     196 S OCXGR=OCXGR_","_OCXDFN_",1"
     197 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     198 ;
     199 K OCXDATA
     200 S OCXDATA(OCXREL,0)=OCXREL
     201 S OCXDATA("B",OCXREL,OCXREL)=""
     202 S OCXGR=OCXGR_","_OCXRUL_",1"
     203 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     204 ;
     205 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     206 .;
     207 .N OCXGR1
     208 .S OCXGR1=OCXGR_","_OCXREL_",1"
     209 .K OCXDATA
     210 .S OCXDATA(OCXELE,0)=OCXELE
     211 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     212 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     213 .S OCXDATA("B",OCXELE,OCXELE)=""
     214 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     215 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     216 .;
     217 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     218 ..N OCXGR2
     219 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     220 ..K OCXDATA
     221 ..S OCXDATA(OCXDFI,0)=OCXDFI
     222 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     223 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     224 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     225 ;
     226 Q 1
     227 ;
     228SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     229 M @ROOT=DATA
     230 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     231 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     232 ;
     233 Q
     234 ;
     235 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m

    r613 r623  
    1 OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R50R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS'
    14         ;  Called from R50R1A+12^OCXOZ0U.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ;
    21         Q:$D(OCXRULE("R50R1B"))
    22         ;
    23         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    24         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - abnormal biochem result:  "_$$GETDATA(DFN,"129^130",58) I 1
    25         E  S OCXCMSG="Procedure uses intravenous contrast media - abnormal biochem result:  "_$$GETDATA(DFN,"129^130",58)
    26         S OCXNMSG=""
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Order Check Message
    31         ;
    32         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    33         Q
    34         ;
    35 R50R2A  ; Verify all Event/Elements of  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...'
    36         ;  Called from EL130+6^OCXOZ0H, and EL133+5^OCXOZ0H.
    37         ;
    38         Q:$G(OCXOERR)
    39         ;
    40         ;      Local Extrinsic Functions
    41         ; MCE130( ---------->  Verify Event/Element: 'CONTRAST MEDIA ORDER'
    42         ; MCE133( ---------->  Verify Event/Element: 'NO CREAT RESULTS W/IN X DAYS'
    43         ;
    44         Q:$G(^OCXS(860.2,50,"INACT"))
    45         ;
    46         I $$MCE130 D
    47         .I $$MCE133 D R50R2B
    48         Q
    49         ;
    50 R50R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...'
    51         ;  Called from R50R2A+12.
    52         ;
    53         Q:$G(OCXOERR)
    54         ;
    55         ;      Local Extrinsic Functions
    56         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    57         ;
    58         Q:$D(OCXRULE("R50R2B"))
    59         ;
    60         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    61         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" I 1
    62         E  S OCXCMSG="Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days"
    63         S OCXNMSG=""
    64         ;
    65         Q:$G(OCXOERR)
    66         ;
    67         ; Send Order Check Message
    68         ;
    69         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    70         Q
    71         ;
    72 R51R1A  ; Verify all Event/Elements of  Rule #51 'RECENT CHOLECYSTOGRAM ORDER'  Relation #1 'RECENT CHOLECGRM'
    73         ;  Called from EL63+5^OCXOZ0H.
    74         ;
    75         Q:$G(OCXOERR)
    76         ;
    77         ;      Local Extrinsic Functions
    78         ; MCE63( ----------->  Verify Event/Element: 'PATIENT HAS RECENT CHOLECYSTOGRAM'
    79         ;
    80         Q:$G(^OCXS(860.2,51,"INACT"))
    81         ;
    82         I $$MCE63 D R51R1B
    83         Q
    84         ;
    85 R51R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #51 'RECENT CHOLECYSTOGRAM ORDER'  Relation #1 'RECENT CHOLECGRM'
    86         ;  Called from R51R1A+10.
    87         ;
    88         Q:$G(OCXOERR)
    89         ;
    90         ;      Local Extrinsic Functions
    91         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    92         ;
    93         Q:$D(OCXRULE("R51R1B"))
    94         ;
    95         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    96         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^15^^Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" I 1
    97         E  S OCXCMSG="Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]"
    98         S OCXNMSG=""
    99         ;
    100         Q:$G(OCXOERR)
    101         ;
    102         ; Send Order Check Message
    103         ;
    104         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    105         Q
    106         ;
    107 R53R1A  ; Verify all Event/Elements of  Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK'  Relation #1 'PHARM PAT OVER 65'
    108         ;  Called from EL64+5^OCXOZ0H.
    109         ;
    110         Q:$G(OCXOERR)
    111         ;
    112         ;      Local Extrinsic Functions
    113         ; MCE64( ----------->  Verify Event/Element: 'PHARMACY PATIENT OVER 65'
    114         ;
    115         Q:$G(^OCXS(860.2,53,"INACT"))
    116         ;
    117         I $$MCE64 D R53R1B
    118         Q
    119         ;
    120 R53R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK'  Relation #1 'PHARM PAT OVER 65'
    121         ;  Called from R53R1A+10.
    122         ;
    123         Q:$G(OCXOERR)
    124         ;
    125         ;      Local Extrinsic Functions
    126         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    127         ;
    128         Q:$D(OCXRULE("R53R1B"))
    129         ;
    130         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    131         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^21^^Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) I 1
    132         E  S OCXCMSG="Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64)
    133         S OCXNMSG=""
    134         ;
    135         Q:$G(OCXOERR)
    136         ;
    137         ; Send Order Check Message
    138         ;
    139         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    140         Q
    141         ;
    142 R54R1A  ; Verify all Event/Elements of  Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...'  Relation #1 'ANGIOGRAM'
    143         ;  Called from EL65+5^OCXOZ0H.
    144         ;
    145         Q:$G(OCXOERR)
    146         ;
    147         ;      Local Extrinsic Functions
    148         ; MCE65( ----------->  Verify Event/Element: 'SESSION ORDER FOR ANGIOGRAM'
    149         ;
    150         Q:$G(^OCXS(860.2,54,"INACT"))
    151         ;
    152         I $$MCE65 D R54R1B
    153         Q
    154         ;
    155 R54R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...'  Relation #1 'ANGIOGRAM'
    156         ;  Called from R54R1A+10.
    157         ;
    158         Q:$G(OCXOERR)
    159         ;
    160         ;      Local Extrinsic Functions
    161         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    162         ;
    163         Q:$D(OCXRULE("R54R1B"))
    164         ;
    165         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    166         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^22^^Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) I 1
    167         E  S OCXCMSG="Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68)
    168         S OCXNMSG=""
    169         ;
    170         Q:$G(OCXOERR)
    171         ;
    172         ; Send Order Check Message
    173         ;
    174         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    175         Q
    176         ;
    177 R55R1A  ; Verify all Event/Elements of  Rule #55 'ALLERGY - CONTRAST MEDIA REACTION'  Relation #1 'ALLERGY'
    178         ;  Called from EL66+5^OCXOZ0H.
    179         ;
    180         Q:$G(OCXOERR)
    181         ;
    182         ;      Local Extrinsic Functions
    183         ; MCE66( ----------->  Verify Event/Element: 'CONTRAST MEDIA ALLERGY'
    184         ;
    185         Q:$G(^OCXS(860.2,55,"INACT"))
    186         ;
    187         I $$MCE66 D R55R1B
    188         Q
    189         ;
    190 R55R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #55 'ALLERGY - CONTRAST MEDIA REACTION'  Relation #1 'ALLERGY'
    191         ;  Called from R55R1A+10.
    192         ;
    193         Q:$G(OCXOERR)
    194         ;
    195         ;      Local Extrinsic Functions
    196         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    197         ;
    198         Q:$D(OCXRULE("R55R1B"))
    199         ;
    200         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    201         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^4^^Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) I 1
    202         E  S OCXCMSG="Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66)
    203         S OCXNMSG=""
    204         ;
    205         Q:$G(OCXOERR)
    206         ;
    207         ; Send Order Check Message
    208         ;
    209         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    210         Q
    211         ;
    212 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    213         ;
    214         N OCXE,VAL,PC S VAL=""
    215         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    216         Q VAL
    217         ;
    218 MCE130()        ; Verify Event/Element: CONTRAST MEDIA ORDER
    219         ;
    220         ;  OCXDF(37) -> PATIENT IEN data field
    221         ;
    222         N OCXRES
    223         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37)
    224         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130))
    225         Q 0
    226         ;
    227 MCE133()        ; Verify Event/Element: NO CREAT RESULTS W/IN X DAYS
    228         ;
    229         ;  OCXDF(37) -> PATIENT IEN data field
    230         ;
    231         N OCXRES
    232         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(133,37)=OCXDF(37)
    233         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),133)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),133))
    234         Q 0
    235         ;
    236 MCE63() ; Verify Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM
    237         ;
    238         ;  OCXDF(37) -> PATIENT IEN data field
    239         ;
    240         N OCXRES
    241         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(63,37)=OCXDF(37)
    242         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),63)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),63))
    243         Q 0
    244         ;
    245 MCE64() ; Verify Event/Element: PHARMACY PATIENT OVER 65
    246         ;
    247         ;  OCXDF(37) -> PATIENT IEN data field
    248         ;
    249         N OCXRES
    250         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(64,37)=OCXDF(37)
    251         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),64)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),64))
    252         Q 0
    253         ;
    254 MCE65() ; Verify Event/Element: SESSION ORDER FOR ANGIOGRAM
    255         ;
    256         ;  OCXDF(37) -> PATIENT IEN data field
    257         ;
    258         N OCXRES
    259         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(65,37)=OCXDF(37)
    260         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),65)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),65))
    261         Q 0
    262         ;
    263 MCE66() ; Verify Event/Element: CONTRAST MEDIA ALLERGY
    264         ;
    265         ;  OCXDF(37) -> PATIENT IEN data field
    266         ;
    267         N OCXRES
    268         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(66,37)=OCXDF(37)
    269         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),66)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),66))
    270         Q 0
    271         ;
     1OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R50R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS'
     14 ;  Called from R50R1A+12^OCXOZ0U.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ;
     21 Q:$D(OCXRULE("R50R1B"))
     22 ;
     23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - abnormal biochem result:  "_$$GETDATA(DFN,"129^130",58) I 1
     25 E  S OCXCMSG="Procedure uses intravenous contrast media - abnormal biochem result:  "_$$GETDATA(DFN,"129^130",58)
     26 S OCXNMSG=""
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Order Check Message
     31 ;
     32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     33 Q
     34 ;
     35R50R2A ; Verify all Event/Elements of  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...'
     36 ;  Called from EL130+6^OCXOZ0H, and EL133+5^OCXOZ0H.
     37 ;
     38 Q:$G(OCXOERR)
     39 ;
     40 ;      Local Extrinsic Functions
     41 ; MCE130( ---------->  Verify Event/Element: 'CONTRAST MEDIA ORDER'
     42 ; MCE133( ---------->  Verify Event/Element: 'NO CREAT RESULTS W/IN X DAYS'
     43 ;
     44 Q:$G(^OCXS(860.2,50,"INACT"))
     45 ;
     46 I $$MCE130 D
     47 .I $$MCE133 D R50R2B
     48 Q
     49 ;
     50R50R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...'  Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...'
     51 ;  Called from R50R2A+12.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;      Local Extrinsic Functions
     56 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     57 ;
     58 Q:$D(OCXRULE("R50R2B"))
     59 ;
     60 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     61 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" I 1
     62 E  S OCXCMSG="Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days"
     63 S OCXNMSG=""
     64 ;
     65 Q:$G(OCXOERR)
     66 ;
     67 ; Send Order Check Message
     68 ;
     69 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     70 Q
     71 ;
     72R51R1A ; Verify all Event/Elements of  Rule #51 'RECENT CHOLECYSTOGRAM ORDER'  Relation #1 'RECENT CHOLECGRM'
     73 ;  Called from EL63+5^OCXOZ0H.
     74 ;
     75 Q:$G(OCXOERR)
     76 ;
     77 ;      Local Extrinsic Functions
     78 ; MCE63( ----------->  Verify Event/Element: 'PATIENT HAS RECENT CHOLECYSTOGRAM'
     79 ;
     80 Q:$G(^OCXS(860.2,51,"INACT"))
     81 ;
     82 I $$MCE63 D R51R1B
     83 Q
     84 ;
     85R51R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #51 'RECENT CHOLECYSTOGRAM ORDER'  Relation #1 'RECENT CHOLECGRM'
     86 ;  Called from R51R1A+10.
     87 ;
     88 Q:$G(OCXOERR)
     89 ;
     90 ;      Local Extrinsic Functions
     91 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     92 ;
     93 Q:$D(OCXRULE("R51R1B"))
     94 ;
     95 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     96 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^15^^Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" I 1
     97 E  S OCXCMSG="Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]"
     98 S OCXNMSG=""
     99 ;
     100 Q:$G(OCXOERR)
     101 ;
     102 ; Send Order Check Message
     103 ;
     104 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     105 Q
     106 ;
     107R53R1A ; Verify all Event/Elements of  Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK'  Relation #1 'PHARM PAT OVER 65'
     108 ;  Called from EL64+5^OCXOZ0H.
     109 ;
     110 Q:$G(OCXOERR)
     111 ;
     112 ;      Local Extrinsic Functions
     113 ; MCE64( ----------->  Verify Event/Element: 'PHARMACY PATIENT OVER 65'
     114 ;
     115 Q:$G(^OCXS(860.2,53,"INACT"))
     116 ;
     117 I $$MCE64 D R53R1B
     118 Q
     119 ;
     120R53R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK'  Relation #1 'PHARM PAT OVER 65'
     121 ;  Called from R53R1A+10.
     122 ;
     123 Q:$G(OCXOERR)
     124 ;
     125 ;      Local Extrinsic Functions
     126 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     127 ;
     128 Q:$D(OCXRULE("R53R1B"))
     129 ;
     130 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     131 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^21^^Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) I 1
     132 E  S OCXCMSG="Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64)
     133 S OCXNMSG=""
     134 ;
     135 Q:$G(OCXOERR)
     136 ;
     137 ; Send Order Check Message
     138 ;
     139 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     140 Q
     141 ;
     142R54R1A ; Verify all Event/Elements of  Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...'  Relation #1 'ANGIOGRAM'
     143 ;  Called from EL65+5^OCXOZ0H.
     144 ;
     145 Q:$G(OCXOERR)
     146 ;
     147 ;      Local Extrinsic Functions
     148 ; MCE65( ----------->  Verify Event/Element: 'SESSION ORDER FOR ANGIOGRAM'
     149 ;
     150 Q:$G(^OCXS(860.2,54,"INACT"))
     151 ;
     152 I $$MCE65 D R54R1B
     153 Q
     154 ;
     155R54R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...'  Relation #1 'ANGIOGRAM'
     156 ;  Called from R54R1A+10.
     157 ;
     158 Q:$G(OCXOERR)
     159 ;
     160 ;      Local Extrinsic Functions
     161 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     162 ;
     163 Q:$D(OCXRULE("R54R1B"))
     164 ;
     165 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     166 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^22^^Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) I 1
     167 E  S OCXCMSG="Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68)
     168 S OCXNMSG=""
     169 ;
     170 Q:$G(OCXOERR)
     171 ;
     172 ; Send Order Check Message
     173 ;
     174 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     175 Q
     176 ;
     177R55R1A ; Verify all Event/Elements of  Rule #55 'ALLERGY - CONTRAST MEDIA REACTION'  Relation #1 'ALLERGY'
     178 ;  Called from EL66+5^OCXOZ0H.
     179 ;
     180 Q:$G(OCXOERR)
     181 ;
     182 ;      Local Extrinsic Functions
     183 ; MCE66( ----------->  Verify Event/Element: 'CONTRAST MEDIA ALLERGY'
     184 ;
     185 Q:$G(^OCXS(860.2,55,"INACT"))
     186 ;
     187 I $$MCE66 D R55R1B
     188 Q
     189 ;
     190R55R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #55 'ALLERGY - CONTRAST MEDIA REACTION'  Relation #1 'ALLERGY'
     191 ;  Called from R55R1A+10.
     192 ;
     193 Q:$G(OCXOERR)
     194 ;
     195 ;      Local Extrinsic Functions
     196 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     197 ;
     198 Q:$D(OCXRULE("R55R1B"))
     199 ;
     200 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     201 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^4^^Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) I 1
     202 E  S OCXCMSG="Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66)
     203 S OCXNMSG=""
     204 ;
     205 Q:$G(OCXOERR)
     206 ;
     207 ; Send Order Check Message
     208 ;
     209 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     210 Q
     211 ;
     212GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     213 ;
     214 N OCXE,VAL,PC S VAL=""
     215 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     216 Q VAL
     217 ;
     218MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER
     219 ;
     220 ;  OCXDF(37) -> PATIENT IEN data field
     221 ;
     222 N OCXRES
     223 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37)
     224 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130))
     225 Q 0
     226 ;
     227MCE133() ; Verify Event/Element: NO CREAT RESULTS W/IN X DAYS
     228 ;
     229 ;  OCXDF(37) -> PATIENT IEN data field
     230 ;
     231 N OCXRES
     232 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(133,37)=OCXDF(37)
     233 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),133)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),133))
     234 Q 0
     235 ;
     236MCE63() ; Verify Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM
     237 ;
     238 ;  OCXDF(37) -> PATIENT IEN data field
     239 ;
     240 N OCXRES
     241 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(63,37)=OCXDF(37)
     242 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),63)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),63))
     243 Q 0
     244 ;
     245MCE64() ; Verify Event/Element: PHARMACY PATIENT OVER 65
     246 ;
     247 ;  OCXDF(37) -> PATIENT IEN data field
     248 ;
     249 N OCXRES
     250 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(64,37)=OCXDF(37)
     251 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),64)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),64))
     252 Q 0
     253 ;
     254MCE65() ; Verify Event/Element: SESSION ORDER FOR ANGIOGRAM
     255 ;
     256 ;  OCXDF(37) -> PATIENT IEN data field
     257 ;
     258 N OCXRES
     259 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(65,37)=OCXDF(37)
     260 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),65)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),65))
     261 Q 0
     262 ;
     263MCE66() ; Verify Event/Element: CONTRAST MEDIA ALLERGY
     264 ;
     265 ;  OCXDF(37) -> PATIENT IEN data field
     266 ;
     267 N OCXRES
     268 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(66,37)=OCXDF(37)
     269 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),66)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),66))
     270 Q 0
     271 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m

    r613 r623  
    1 OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R56R1A  ; Verify all Event/Elements of  Rule #56 'RECENT BARIUM STUDY'  Relation #1 'BARIUM'
    14         ;  Called from EL67+5^OCXOZ0H.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE67( ----------->  Verify Event/Element: 'RECENT BARIUM STUDY ORDERED'
    20         ;
    21         Q:$G(^OCXS(860.2,56,"INACT"))
    22         ;
    23         I $$MCE67 D R56R1B
    24         Q
    25         ;
    26 R56R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #56 'RECENT BARIUM STUDY'  Relation #1 'BARIUM'
    27         ;  Called from R56R1A+10.
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ;      Local Extrinsic Functions
    32         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    33         ;
    34         Q:$D(OCXRULE("R56R1B"))
    35         ;
    36         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    37         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^14^^Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" I 1
    38         E  S OCXCMSG="Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]"
    39         S OCXNMSG=""
    40         ;
    41         Q:$G(OCXOERR)
    42         ;
    43         ; Send Order Check Message
    44         ;
    45         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    46         Q
    47         ;
    48 R57R1A  ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #1 'CLOZAPINE AND (NO WBC W/IN 7 DAYS OR NO ANC W/IN 7...'
    49         ;  Called from EL116+5^OCXOZ0H, and EL117+5^OCXOZ0H, and EL118+5^OCXOZ0H.
    50         ;
    51         Q:$G(OCXOERR)
    52         ;
    53         ;      Local Extrinsic Functions
    54         ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
    55         ; MCE117( ---------->  Verify Event/Element: 'CLOZAPINE NO ANC W/IN 7 DAYS'
    56         ; MCE118( ---------->  Verify Event/Element: 'CLOZAPINE NO WBC W/IN 7 DAYS'
    57         ;
    58         Q:$G(^OCXS(860.2,57,"INACT"))
    59         ;
    60         I $$MCE116 D
    61         .I $$MCE118 D R57R1B
    62         .I $$MCE117 D R57R1B
    63         Q
    64         ;
    65 R57R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #1 'CLOZAPINE AND (NO WBC W/IN 7 DAYS OR NO ANC W/IN 7...'
    66         ;  Called from R57R1A+13.
    67         ;
    68         Q:$G(OCXOERR)
    69         ;
    70         ;      Local Extrinsic Functions
    71         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    72         ;
    73         Q:$D(OCXRULE("R57R1B"))
    74         ;
    75         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    76         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine orders require a CBC/Diff within past 7 days.  Please order CBC/Diff with WBC and ANC immediately.  Most recent results - "_$$GETDATA(DFN,"116^117^118",130) I 1
    77         E  S OCXCMSG="Clozapine orders require a CBC/Diff within past 7 days.  Please order CBC/Diff with WBC and ANC immediately.  Most recent results - "_$$GETDATA(DFN,"116^117^118",130)
    78         S OCXNMSG=""
    79         ;
    80         Q:$G(OCXOERR)
    81         ;
    82         ; Send Order Check Message
    83         ;
    84         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    85         Q
    86         ;
    87 R57R2A  ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #2 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)'
    88         ;  Called from EL116+6^OCXOZ0H, and EL114+5^OCXOZ0I, and EL119+5^OCXOZ0I.
    89         ;
    90         Q:$G(OCXOERR)
    91         ;
    92         ;      Local Extrinsic Functions
    93         ; MCE114( ---------->  Verify Event/Element: 'CLOZAPINE ANC < 1.5'
    94         ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
    95         ; MCE119( ---------->  Verify Event/Element: 'CLOZAPINE WBC < 3.0'
    96         ;
    97         Q:$G(^OCXS(860.2,57,"INACT"))
    98         ;
    99         I $$MCE116 D
    100         .I $$MCE119 D R57R2B
    101         .I $$MCE114 D R57R2B
    102         Q
    103         ;
    104 R57R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #2 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)'
    105         ;  Called from R57R2A+13.
    106         ;
    107         Q:$G(OCXOERR)
    108         ;
    109         ;      Local Extrinsic Functions
    110         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    111         ;
    112         Q:$D(OCXRULE("R57R2B"))
    113         ;
    114         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    115         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) I 1
    116         E  S OCXCMSG="WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130)
    117         S OCXNMSG=""
    118         ;
    119         Q:$G(OCXOERR)
    120         ;
    121         ; Send Order Check Message
    122         ;
    123         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    124         Q
    125         ;
    126 R57R3A  ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5'
    127         ;  Called from EL116+7^OCXOZ0H, and EL115+5^OCXOZ0I, and EL120+5^OCXOZ0I.
    128         ;
    129         Q:$G(OCXOERR)
    130         ;
    131         ;      Local Extrinsic Functions
    132         ; MCE115( ---------->  Verify Event/Element: 'CLOZAPINE ANC >= 1.5'
    133         ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
    134         ; MCE120( ---------->  Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5'
    135         ;
    136         Q:$G(^OCXS(860.2,57,"INACT"))
    137         ;
    138         I $$MCE116 D
    139         .I $$MCE120 D
    140         ..I $$MCE115 D R57R3B
    141         Q
    142         ;
    143 R57R3B  ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5'
    144         ;  Called from R57R3A+14.
    145         ;
    146         Q:$G(OCXOERR)
    147         ;
    148         ;      Local Extrinsic Functions
    149         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    150         ;
    151         Q:$D(OCXRULE("R57R3B"))
    152         ;
    153         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    154         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly.  Most recent results - "_$$GETDATA(DFN,"115^116^120",130) I 1
    155         E  S OCXCMSG="WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly.  Most recent results - "_$$GETDATA(DFN,"115^116^120",130)
    156         S OCXNMSG=""
    157         ;
    158         Q:$G(OCXOERR)
    159         ;
    160         ; Send Order Check Message
    161         ;
    162         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    163         Q
    164         ;
    165 R57R4A  ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #4 'CLOZAPINE AND 1.5 <= ANC < 2.0'
    166         ;  Called from EL116+8^OCXOZ0H, and EL140+5^OCXOZ0I.
    167         ;
    168         Q:$G(OCXOERR)
    169         ;
    170         ;      Local Extrinsic Functions
    171         ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
    172         ; MCE140( ---------->  Verify Event/Element: 'CLOZAPINE ANC >= 1.5 & < 2.0'
    173         ;
    174         Q:$G(^OCXS(860.2,57,"INACT"))
    175         ;
    176         I $$MCE116 D
    177         .I $$MCE140 D R57R4B^OCXOZ0X
    178         Q
    179         ;
    180 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    181         ;
    182         N OCXE,VAL,PC S VAL=""
    183         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    184         Q VAL
    185         ;
    186 MCE114()        ; Verify Event/Element: CLOZAPINE ANC < 1.5
    187         ;
    188         ;  OCXDF(37) -> PATIENT IEN data field
    189         ;
    190         N OCXRES
    191         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(114,37)=OCXDF(37)
    192         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),114)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),114))
    193         Q 0
    194         ;
    195 MCE115()        ; Verify Event/Element: CLOZAPINE ANC >= 1.5
    196         ;
    197         ;  OCXDF(37) -> PATIENT IEN data field
    198         ;
    199         N OCXRES
    200         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(115,37)=OCXDF(37)
    201         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),115)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),115))
    202         Q 0
    203         ;
    204 MCE116()        ; Verify Event/Element: CLOZAPINE DRUG SELECTED
    205         ;
    206         ;  OCXDF(37) -> PATIENT IEN data field
    207         ;
    208         N OCXRES
    209         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37)
    210         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116))
    211         Q 0
    212         ;
    213 MCE117()        ; Verify Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS
    214         ;
    215         ;  OCXDF(37) -> PATIENT IEN data field
    216         ;
    217         N OCXRES
    218         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(117,37)=OCXDF(37)
    219         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),117)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),117))
    220         Q 0
    221         ;
    222 MCE118()        ; Verify Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS
    223         ;
    224         ;  OCXDF(37) -> PATIENT IEN data field
    225         ;
    226         N OCXRES
    227         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(118,37)=OCXDF(37)
    228         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),118)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),118))
    229         Q 0
    230         ;
    231 MCE119()        ; Verify Event/Element: CLOZAPINE WBC < 3.0
    232         ;
    233         ;  OCXDF(37) -> PATIENT IEN data field
    234         ;
    235         N OCXRES
    236         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(119,37)=OCXDF(37)
    237         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),119)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),119))
    238         Q 0
    239         ;
    240 MCE120()        ; Verify Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5
    241         ;
    242         ;  OCXDF(37) -> PATIENT IEN data field
    243         ;
    244         N OCXRES
    245         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(120,37)=OCXDF(37)
    246         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),120)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),120))
    247         Q 0
    248         ;
    249 MCE140()        ; Verify Event/Element: CLOZAPINE ANC >= 1.5 & < 2.0
    250         ;
    251         ;  OCXDF(37) -> PATIENT IEN data field
    252         ;
    253         N OCXRES
    254         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(140,37)=OCXDF(37)
    255         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),140)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),140))
    256         Q 0
    257         ;
    258 MCE67() ; Verify Event/Element: RECENT BARIUM STUDY ORDERED
    259         ;
    260         ;  OCXDF(37) -> PATIENT IEN data field
    261         ;
    262         N OCXRES
    263         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(67,37)=OCXDF(37)
    264         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),67)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),67))
    265         Q 0
    266         ;
     1OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R56R1A ; Verify all Event/Elements of  Rule #56 'RECENT BARIUM STUDY'  Relation #1 'BARIUM'
     14 ;  Called from EL67+5^OCXOZ0H.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE67( ----------->  Verify Event/Element: 'RECENT BARIUM STUDY ORDERED'
     20 ;
     21 Q:$G(^OCXS(860.2,56,"INACT"))
     22 ;
     23 I $$MCE67 D R56R1B
     24 Q
     25 ;
     26R56R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #56 'RECENT BARIUM STUDY'  Relation #1 'BARIUM'
     27 ;  Called from R56R1A+10.
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ;      Local Extrinsic Functions
     32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     33 ;
     34 Q:$D(OCXRULE("R56R1B"))
     35 ;
     36 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     37 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^14^^Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" I 1
     38 E  S OCXCMSG="Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]"
     39 S OCXNMSG=""
     40 ;
     41 Q:$G(OCXOERR)
     42 ;
     43 ; Send Order Check Message
     44 ;
     45 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     46 Q
     47 ;
     48R57R1A ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #1 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)'
     49 ;  Called from EL114+5^OCXOZ0H, and EL116+5^OCXOZ0H, and EL119+5^OCXOZ0H.
     50 ;
     51 Q:$G(OCXOERR)
     52 ;
     53 ;      Local Extrinsic Functions
     54 ; MCE114( ---------->  Verify Event/Element: 'CLOZAPINE ANC < 1.5'
     55 ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
     56 ; MCE119( ---------->  Verify Event/Element: 'CLOZAPINE WBC < 3.0'
     57 ;
     58 Q:$G(^OCXS(860.2,57,"INACT"))
     59 ;
     60 I $$MCE116 D
     61 .I $$MCE119 D R57R1B
     62 .I $$MCE114 D R57R1B
     63 Q
     64 ;
     65R57R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #1 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)'
     66 ;  Called from R57R1A+13.
     67 ;
     68 Q:$G(OCXOERR)
     69 ;
     70 ;      Local Extrinsic Functions
     71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     72 ;
     73 Q:$D(OCXRULE("R57R1B"))
     74 ;
     75 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     76 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) I 1
     77 E  S OCXCMSG="WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130)
     78 S OCXNMSG=""
     79 ;
     80 Q:$G(OCXOERR)
     81 ;
     82 ; Send Order Check Message
     83 ;
     84 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     85 Q
     86 ;
     87R57R2A ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #2 'CLOZAPINE AND NO WBC W/IN 7 DAYS'
     88 ;  Called from EL116+6^OCXOZ0H, and EL118+5^OCXOZ0H.
     89 ;
     90 Q:$G(OCXOERR)
     91 ;
     92 ;      Local Extrinsic Functions
     93 ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
     94 ; MCE118( ---------->  Verify Event/Element: 'CLOZAPINE NO WBC W/IN 7 DAYS'
     95 ;
     96 Q:$G(^OCXS(860.2,57,"INACT"))
     97 ;
     98 I $$MCE116 D
     99 .I $$MCE118 D R57R2B
     100 Q
     101 ;
     102R57R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #2 'CLOZAPINE AND NO WBC W/IN 7 DAYS'
     103 ;  Called from R57R2A+12.
     104 ;
     105 Q:$G(OCXOERR)
     106 ;
     107 ;      Local Extrinsic Functions
     108 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     109 ;
     110 Q:$D(OCXRULE("R57R2B"))
     111 ;
     112 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     113 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine orders require a CBC/Diff within past 7 days.  Please order CBC/Diff with WBC and ANC immediately.  Most recent results - "_$$GETDATA(DFN,"116^118",130) I 1
     114 E  S OCXCMSG="Clozapine orders require a CBC/Diff within past 7 days.  Please order CBC/Diff with WBC and ANC immediately.  Most recent results - "_$$GETDATA(DFN,"116^118",130)
     115 S OCXNMSG=""
     116 ;
     117 Q:$G(OCXOERR)
     118 ;
     119 ; Send Order Check Message
     120 ;
     121 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     122 Q
     123 ;
     124R57R3A ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND NO ANC W/IN 7 D...'
     125 ;  Called from EL116+7^OCXOZ0H, and EL117+5^OCXOZ0H, and EL120+5^OCXOZ0I.
     126 ;
     127 Q:$G(OCXOERR)
     128 ;
     129 ;      Local Extrinsic Functions
     130 ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
     131 ; MCE117( ---------->  Verify Event/Element: 'CLOZAPINE NO ANC W/IN 7 DAYS'
     132 ; MCE120( ---------->  Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5'
     133 ;
     134 Q:$G(^OCXS(860.2,57,"INACT"))
     135 ;
     136 I $$MCE116 D
     137 .I $$MCE120 D
     138 ..I $$MCE117 D R57R3B
     139 Q
     140 ;
     141R57R3B ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND NO ANC W/IN 7 D...'
     142 ;  Called from R57R3A+14.
     143 ;
     144 Q:$G(OCXOERR)
     145 ;
     146 ;      Local Extrinsic Functions
     147 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     148 ;
     149 Q:$D(OCXRULE("R57R3B"))
     150 ;
     151 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     152 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^"_$$GETDATA(DFN,"116^117^120",145)_"  Most recent results - "_$$GETDATA(DFN,"116^117^120",130) I 1
     153 E  S OCXCMSG=$$GETDATA(DFN,"116^117^120",145)_"  Most recent results - "_$$GETDATA(DFN,"116^117^120",130)
     154 S OCXNMSG=""
     155 ;
     156 Q:$G(OCXOERR)
     157 ;
     158 ; Send Order Check Message
     159 ;
     160 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     161 Q
     162 ;
     163R57R4A ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #4 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5'
     164 ;  Called from EL116+8^OCXOZ0H, and EL120+6^OCXOZ0I, and EL115+5^OCXOZ0I.
     165 ;
     166 Q:$G(OCXOERR)
     167 ;
     168 ;      Local Extrinsic Functions
     169 ; MCE115( ---------->  Verify Event/Element: 'CLOZAPINE ANC >= 1.5'
     170 ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
     171 ; MCE120( ---------->  Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5'
     172 ;
     173 Q:$G(^OCXS(860.2,57,"INACT"))
     174 ;
     175 I $$MCE116 D
     176 .I $$MCE120 D
     177 ..I $$MCE115 D R57R4B^OCXOZ0X
     178 Q
     179 ;
     180GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     181 ;
     182 N OCXE,VAL,PC S VAL=""
     183 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     184 Q VAL
     185 ;
     186MCE114() ; Verify Event/Element: CLOZAPINE ANC < 1.5
     187 ;
     188 ;  OCXDF(37) -> PATIENT IEN data field
     189 ;
     190 N OCXRES
     191 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(114,37)=OCXDF(37)
     192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),114)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),114))
     193 Q 0
     194 ;
     195MCE115() ; Verify Event/Element: CLOZAPINE ANC >= 1.5
     196 ;
     197 ;  OCXDF(37) -> PATIENT IEN data field
     198 ;
     199 N OCXRES
     200 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(115,37)=OCXDF(37)
     201 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),115)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),115))
     202 Q 0
     203 ;
     204MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED
     205 ;
     206 ;  OCXDF(37) -> PATIENT IEN data field
     207 ;
     208 N OCXRES
     209 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37)
     210 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116))
     211 Q 0
     212 ;
     213MCE117() ; Verify Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS
     214 ;
     215 ;  OCXDF(37) -> PATIENT IEN data field
     216 ;
     217 N OCXRES
     218 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(117,37)=OCXDF(37)
     219 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),117)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),117))
     220 Q 0
     221 ;
     222MCE118() ; Verify Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS
     223 ;
     224 ;  OCXDF(37) -> PATIENT IEN data field
     225 ;
     226 N OCXRES
     227 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(118,37)=OCXDF(37)
     228 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),118)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),118))
     229 Q 0
     230 ;
     231MCE119() ; Verify Event/Element: CLOZAPINE WBC < 3.0
     232 ;
     233 ;  OCXDF(37) -> PATIENT IEN data field
     234 ;
     235 N OCXRES
     236 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(119,37)=OCXDF(37)
     237 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),119)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),119))
     238 Q 0
     239 ;
     240MCE120() ; Verify Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5
     241 ;
     242 ;  OCXDF(37) -> PATIENT IEN data field
     243 ;
     244 N OCXRES
     245 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(120,37)=OCXDF(37)
     246 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),120)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),120))
     247 Q 0
     248 ;
     249MCE67() ; Verify Event/Element: RECENT BARIUM STUDY ORDERED
     250 ;
     251 ;  OCXDF(37) -> PATIENT IEN data field
     252 ;
     253 N OCXRES
     254 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(67,37)=OCXDF(37)
     255 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),67)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),67))
     256 Q 0
     257 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m

    r613 r623  
    1 OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R57R4B  ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #4 'CLOZAPINE AND 1.5 <= ANC < 2.0'
    14         ;  Called from R57R4A+12^OCXOZ0W.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ;
    21         Q:$D(OCXRULE("R57R4B"))
    22         ;
    23         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    24         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^ANC between 1.5 and 2.0 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly.  Most recent results - "_$$GETDATA(DFN,"116^140",130) I 1
    25         E  S OCXCMSG="ANC between 1.5 and 2.0 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly.  Most recent results - "_$$GETDATA(DFN,"116^140",130)
    26         S OCXNMSG=""
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Order Check Message
    31         ;
    32         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    33         Q
    34         ;
    35 R59R1A  ; Verify all Event/Elements of  Rule #59 'AMINOGLYCOSIDE ORDER'  Relation #1 'AGS ORDER'
    36         ;  Called from EL71+5^OCXOZ0I.
    37         ;
    38         Q:$G(OCXOERR)
    39         ;
    40         ;      Local Extrinsic Functions
    41         ; MCE71( ----------->  Verify Event/Element: 'AMINOGLYCOSIDE ORDER SESSION'
    42         ;
    43         Q:$G(^OCXS(860.2,59,"INACT"))
    44         ;
    45         I $$MCE71 D R59R1B
    46         Q
    47         ;
    48 R59R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #59 'AMINOGLYCOSIDE ORDER'  Relation #1 'AGS ORDER'
    49         ;  Called from R59R1A+10.
    50         ;
    51         Q:$G(OCXOERR)
    52         ;
    53         ;      Local Extrinsic Functions
    54         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    55         ;
    56         Q:$D(OCXRULE("R59R1B"))
    57         ;
    58         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    59         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^20^^Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" I 1
    60         E  S OCXCMSG="Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]"
    61         S OCXNMSG=""
    62         ;
    63         Q:$G(OCXOERR)
    64         ;
    65         ; Send Order Check Message
    66         ;
    67         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    68         Q
    69         ;
    70 R60R1A  ; Verify all Event/Elements of  Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK'  Relation #1 'TOO BIG'
    71         ;  Called from EL72+5^OCXOZ0I.
    72         ;
    73         Q:$G(OCXOERR)
    74         ;
    75         ;      Local Extrinsic Functions
    76         ; MCE72( ----------->  Verify Event/Element: 'PATIENT OVER CT OR MRI DEVICE LIMITATIONS'
    77         ;
    78         Q:$G(^OCXS(860.2,60,"INACT"))
    79         ;
    80         I $$MCE72 D R60R1B
    81         Q
    82         ;
    83 R60R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK'  Relation #1 'TOO BIG'
    84         ;  Called from R60R1A+10.
    85         ;
    86         Q:$G(OCXOERR)
    87         ;
    88         ;      Local Extrinsic Functions
    89         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    90         ;
    91         Q:$D(OCXRULE("R60R1B"))
    92         ;
    93         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    94         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^8^^Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." I 1
    95         E  S OCXCMSG="Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"."
    96         S OCXNMSG=""
    97         ;
    98         Q:$G(OCXOERR)
    99         ;
    100         ; Send Order Check Message
    101         ;
    102         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    103         Q
    104         ;
    105 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    106         ;
    107         N OCXE,VAL,PC S VAL=""
    108         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    109         Q VAL
    110         ;
    111 MCE71() ; Verify Event/Element: AMINOGLYCOSIDE ORDER SESSION
    112         ;
    113         ;  OCXDF(37) -> PATIENT IEN data field
    114         ;
    115         N OCXRES
    116         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(71,37)=OCXDF(37)
    117         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),71)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),71))
    118         Q 0
    119         ;
    120 MCE72() ; Verify Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS
    121         ;
    122         ;  OCXDF(37) -> PATIENT IEN data field
    123         ;
    124         N OCXRES
    125         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(72,37)=OCXDF(37)
    126         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),72)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),72))
    127         Q 0
    128         ;
     1OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R57R4B ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #4 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5'
     14 ;  Called from R57R4A+14^OCXOZ0W.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ;
     21 Q:$D(OCXRULE("R57R4B"))
     22 ;
     23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly.  Most recent results - "_$$GETDATA(DFN,"115^116^120",130) I 1
     25 E  S OCXCMSG="WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly.  Most recent results - "_$$GETDATA(DFN,"115^116^120",130)
     26 S OCXNMSG=""
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Order Check Message
     31 ;
     32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     33 Q
     34 ;
     35R57R5A ; Verify all Event/Elements of  Rule #57 'CLOZAPINE'  Relation #5 'CLOZAPINE AND WBC >= 3.5'
     36 ;  Called from EL116+9^OCXOZ0H, and EL121+5^OCXOZ0I.
     37 ;
     38 Q:$G(OCXOERR)
     39 ;
     40 ;      Local Extrinsic Functions
     41 ; MCE116( ---------->  Verify Event/Element: 'CLOZAPINE DRUG SELECTED'
     42 ; MCE121( ---------->  Verify Event/Element: 'CLOZAPINE WBC >= 3.5'
     43 ;
     44 Q:$G(^OCXS(860.2,57,"INACT"))
     45 ;
     46 I $$MCE116 D
     47 .I $$MCE121 D R57R5B
     48 Q
     49 ;
     50R57R5B ; Send Order Check, Notication messages and/or Execute code for  Rule #57 'CLOZAPINE'  Relation #5 'CLOZAPINE AND WBC >= 3.5'
     51 ;  Called from R57R5A+12.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;      Local Extrinsic Functions
     56 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     57 ;
     58 Q:$D(OCXRULE("R57R5B"))
     59 ;
     60 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     61 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine - most recent results - "_$$GETDATA(DFN,"116^121",130) I 1
     62 E  S OCXCMSG="Clozapine - most recent results - "_$$GETDATA(DFN,"116^121",130)
     63 S OCXNMSG=""
     64 ;
     65 Q:$G(OCXOERR)
     66 ;
     67 ; Send Order Check Message
     68 ;
     69 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     70 Q
     71 ;
     72R59R1A ; Verify all Event/Elements of  Rule #59 'AMINOGLYCOSIDE ORDER'  Relation #1 'AGS ORDER'
     73 ;  Called from EL71+5^OCXOZ0I.
     74 ;
     75 Q:$G(OCXOERR)
     76 ;
     77 ;      Local Extrinsic Functions
     78 ; MCE71( ----------->  Verify Event/Element: 'AMINOGLYCOSIDE ORDER SESSION'
     79 ;
     80 Q:$G(^OCXS(860.2,59,"INACT"))
     81 ;
     82 I $$MCE71 D R59R1B
     83 Q
     84 ;
     85R59R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #59 'AMINOGLYCOSIDE ORDER'  Relation #1 'AGS ORDER'
     86 ;  Called from R59R1A+10.
     87 ;
     88 Q:$G(OCXOERR)
     89 ;
     90 ;      Local Extrinsic Functions
     91 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     92 ;
     93 Q:$D(OCXRULE("R59R1B"))
     94 ;
     95 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     96 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^20^^Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" I 1
     97 E  S OCXCMSG="Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]"
     98 S OCXNMSG=""
     99 ;
     100 Q:$G(OCXOERR)
     101 ;
     102 ; Send Order Check Message
     103 ;
     104 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     105 Q
     106 ;
     107R60R1A ; Verify all Event/Elements of  Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK'  Relation #1 'TOO BIG'
     108 ;  Called from EL72+5^OCXOZ0I.
     109 ;
     110 Q:$G(OCXOERR)
     111 ;
     112 ;      Local Extrinsic Functions
     113 ; MCE72( ----------->  Verify Event/Element: 'PATIENT OVER CT OR MRI DEVICE LIMITATIONS'
     114 ;
     115 Q:$G(^OCXS(860.2,60,"INACT"))
     116 ;
     117 I $$MCE72 D R60R1B
     118 Q
     119 ;
     120R60R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK'  Relation #1 'TOO BIG'
     121 ;  Called from R60R1A+10.
     122 ;
     123 Q:$G(OCXOERR)
     124 ;
     125 ;      Local Extrinsic Functions
     126 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     127 ;
     128 Q:$D(OCXRULE("R60R1B"))
     129 ;
     130 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     131 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^8^^Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." I 1
     132 E  S OCXCMSG="Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"."
     133 S OCXNMSG=""
     134 ;
     135 Q:$G(OCXOERR)
     136 ;
     137 ; Send Order Check Message
     138 ;
     139 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     140 Q
     141 ;
     142GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     143 ;
     144 N OCXE,VAL,PC S VAL=""
     145 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     146 Q VAL
     147 ;
     148MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED
     149 ;
     150 ;  OCXDF(37) -> PATIENT IEN data field
     151 ;
     152 N OCXRES
     153 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37)
     154 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116))
     155 Q 0
     156 ;
     157MCE121() ; Verify Event/Element: CLOZAPINE WBC >= 3.5
     158 ;
     159 ;  OCXDF(37) -> PATIENT IEN data field
     160 ;
     161 N OCXRES
     162 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(121,37)=OCXDF(37)
     163 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),121)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),121))
     164 Q 0
     165 ;
     166MCE71() ; Verify Event/Element: AMINOGLYCOSIDE ORDER SESSION
     167 ;
     168 ;  OCXDF(37) -> PATIENT IEN data field
     169 ;
     170 N OCXRES
     171 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(71,37)=OCXDF(37)
     172 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),71)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),71))
     173 Q 0
     174 ;
     175MCE72() ; Verify Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS
     176 ;
     177 ;  OCXDF(37) -> PATIENT IEN data field
     178 ;
     179 N OCXRES
     180 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(72,37)=OCXDF(37)
     181 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),72)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),72))
     182 Q 0
     183 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m

    r613 r623  
    1 OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R61R1A  ; Verify all Event/Elements of  Rule #61 'CREATININE CLEARANCE ESTIMATION'  Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...'
    14         ;  Called from EL73+5^OCXOZ0I, and EL96+5^OCXOZ0I, and EL97+5^OCXOZ0I.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE73( ----------->  Verify Event/Element: 'CREATININE CLEARANCE ESTIMATE'
    20         ; MCE96( ----------->  Verify Event/Element: 'CREATININE CLEARANCE DATE/TIME'
    21         ; MCE97( ----------->  Verify Event/Element: 'RENAL RESULTS'
    22         ;
    23         Q:$G(^OCXS(860.2,61,"INACT"))
    24         ;
    25         I $$MCE73 D
    26         .I $$MCE96 D R61R1B
    27         .I $$MCE97 D R61R1B
    28         Q
    29         ;
    30 R61R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #61 'CREATININE CLEARANCE ESTIMATION'  Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...'
    31         ;  Called from R61R1A+13.
    32         ;
    33         Q:$G(OCXOERR)
    34         ;
    35         ;      Local Extrinsic Functions
    36         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    37         ;
    38         Q:$D(OCXRULE("R61R1B"))
    39         ;
    40         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    41         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^1^^Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" I 1
    42         E  S OCXCMSG="Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]"
    43         S OCXNMSG=""
    44         ;
    45         Q:$G(OCXOERR)
    46         ;
    47         ; Send Order Check Message
    48         ;
    49         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    50         Q
    51         ;
    52 CRCL(DFN)       ;  Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
    53         ;
    54         N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
    55         N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
    56         S RSLT="0^<Unavailable>"
    57         S PSCR="^^^^^^0"
    58         D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
    59         Q:'$D(ORW) RSLT
    60         S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
    61         S ABW=ABW/2.2  ;ABW (actual body weight) in kg
    62         D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
    63         Q:'$D(ORH) RSLT
    64         S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
    65         S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
    66         S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
    67         S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
    68         S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
    69         S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D
    70         .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D
    71         ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
    72         ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
    73         S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
    74         S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
    75         ;
    76         S HTGT60=$S(HT>60:(HT-60)*2.3,1:0)  ;if ht > 60 inches
    77         I HTGT60>0 D
    78         .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight
    79         .S BWRATIO=(ABW/IBW)  ;body weight ratio
    80         .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
    81         .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
    82         .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
    83         .E  S ADJBW=LOWBW
    84         I +$G(ADJBW)<1 D
    85         .S ADJBW=ABW
    86         S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
    87         ;
    88         S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
    89         S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
    90         Q RSLT
    91         ;
    92 DT2INT(OCXDT)   ;      This Local Extrinsic Function converts a date into an integer
    93         ; By taking the Years, Months, Days, Hours and Minutes converting
    94         ; Them into Seconds and then adding them all together into one big integer
    95         ;
    96         Q:'$L($G(OCXDT)) ""
    97         N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
    98         ;
    99         I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
    100         .N OCXHR,OCXMIN,OCXTIME
    101         .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
    102         .S:(OCXDT["Midnight") OCXHR=00
    103         .S:(OCXDT["PM") OCXHR=OCXHR+12
    104         .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
    105         ;
    106         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
    107         .N OCXMON
    108         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    109         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
    110         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
    111         ;
    112         I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
    113         .N OCXMON
    114         .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
    115         .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
    116         .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
    117         ;
    118         I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
    119         .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
    120         .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
    121         ;
    122         I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
    123         ;
    124         I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
    125         ;
    126         I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
    127         ;
    128         Q OCXVAL
    129         ;
    130 FLAB(DFN,OCXLIST,OCXSPEC)       ;  Compiler Function: FORMATTED LAB RESULTS
    131         ;
    132         Q:'$G(DFN) "<Patient Not Specified>"
    133         Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
    134         N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
    135         I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
    136         F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
    137         .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
    138         .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
    139         .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
    140         ..I $L($G(OCXSL)) D
    141         ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
    142         ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
    143         .....S OCXA($P(OCXX,U,7))=OCXX
    144         ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
    145         ..Q:'$L(OCXX)
    146         .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
    147         .I $L(OCXX) D
    148         ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
    149         ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
    150         ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
    151         .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
    152         Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
    153         ;
    154 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    155         ;
    156         N OCXE,VAL,PC S VAL=""
    157         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    158         Q VAL
    159         ;
    160 MCE73() ; Verify Event/Element: CREATININE CLEARANCE ESTIMATE
    161         ;
    162         ;  OCXDF(37) -> PATIENT IEN data field
    163         ;
    164         N OCXRES
    165         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(73,37)=OCXDF(37)
    166         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),73)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),73))
    167         Q 0
    168         ;
    169 MCE96() ; Verify Event/Element: CREATININE CLEARANCE DATE/TIME
    170         ;
    171         ;  OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field
    172         ;  OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field
    173         ;  OCXDF(77) -> CREATININE CLEARANCE (ESTIM) DATE data field
    174         ;  OCXDF(37) -> PATIENT IEN data field
    175         ;
    176         N OCXRES
    177         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(96,37)=OCXDF(37)
    178         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),96)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),96))
    179         S OCXRES(96)=0,OCXDF(77)=$$DT2INT($P($$CRCL(OCXDF(37)),"^",1)) I $L(OCXDF(77)) S OCXRES(96,77)=OCXDF(77) I (OCXDF(77)>$$DT2INT(0))
    180         E  Q 0
    181         S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(96)=11 M ^TMP("OCXCHK",$J,OCXDF(37),96)=OCXRES(96)
    182         Q +OCXRES(96)
    183         ;
    184 MCE97() ; Verify Event/Element: RENAL RESULTS
    185         ;
    186         ;  OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field
    187         ;  OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field
    188         ;  OCXDF(37) -> PATIENT IEN data field
    189         ;
    190         N OCXRES
    191         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(97,37)=OCXDF(37)
    192         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),97)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),97))
    193         S OCXRES(97)=0,OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") I '(OCXDF(64)="<Results Not Found>")
    194         E  Q 0
    195         S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(97)=11 M ^TMP("OCXCHK",$J,OCXDF(37),97)=OCXRES(97)
    196         Q +OCXRES(97)
    197         ;
    198 TERMLKUP(OCXTERM,OCXLIST)       ;
    199         Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
    200         ;
     1OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R61R1A ; Verify all Event/Elements of  Rule #61 'CREATININE CLEARANCE ESTIMATION'  Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...'
     14 ;  Called from EL73+5^OCXOZ0I, and EL96+5^OCXOZ0I, and EL97+5^OCXOZ0I.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE73( ----------->  Verify Event/Element: 'CREATININE CLEARANCE ESTIMATE'
     20 ; MCE96( ----------->  Verify Event/Element: 'CREATININE CLEARANCE DATE/TIME'
     21 ; MCE97( ----------->  Verify Event/Element: 'RENAL RESULTS'
     22 ;
     23 Q:$G(^OCXS(860.2,61,"INACT"))
     24 ;
     25 I $$MCE73 D
     26 .I $$MCE96 D R61R1B
     27 .I $$MCE97 D R61R1B
     28 Q
     29 ;
     30R61R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #61 'CREATININE CLEARANCE ESTIMATION'  Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...'
     31 ;  Called from R61R1A+13.
     32 ;
     33 Q:$G(OCXOERR)
     34 ;
     35 ;      Local Extrinsic Functions
     36 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     37 ;
     38 Q:$D(OCXRULE("R61R1B"))
     39 ;
     40 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     41 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^1^^Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" I 1
     42 E  S OCXCMSG="Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_")  [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]"
     43 S OCXNMSG=""
     44 ;
     45 Q:$G(OCXOERR)
     46 ;
     47 ; Send Order Check Message
     48 ;
     49 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     50 Q
     51 ;
     52CRCL(DFN) ;  Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
     53 ;
     54 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
     55 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
     56 S RSLT="0^<Unavailable>"
     57 S PSCR="^^^^^^0"
     58 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
     59 Q:'$D(ORW) RSLT
     60 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
     61 S ABW=ABW/2.2  ;ABW (actual body weight) in kg
     62 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
     63 Q:'$D(ORH) RSLT
     64 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
     65 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
     66 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
     67 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
     68 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
     69 S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D
     70 .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D
     71 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
     72 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
     73 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
     74 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
     75 ;
     76 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0)  ;if ht > 60 inches
     77 I HTGT60>0 D
     78 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight
     79 .S BWRATIO=(ABW/IBW)  ;body weight ratio
     80 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
     81 .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
     82 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
     83 .E  S ADJBW=LOWBW
     84 I +$G(ADJBW)<1 D
     85 .S ADJBW=ABW
     86 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
     87 ;
     88 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
     89 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
     90 Q RSLT
     91 ;
     92DT2INT(OCXDT) ;      This Local Extrinsic Function converts a date into an integer
     93 ; By taking the Years, Months, Days, Hours and Minutes converting
     94 ; Them into Seconds and then adding them all together into one big integer
     95 ;
     96 Q:'$L($G(OCXDT)) ""
     97 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
     98 ;
     99 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D  ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
     100 .N OCXHR,OCXMIN,OCXTIME
     101 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
     102 .S:(OCXDT["Midnight") OCXHR=00
     103 .S:(OCXDT["PM") OCXHR=OCXHR+12
     104 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
     105 ;
     106 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
     107 .N OCXMON
     108 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     109 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
     110 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
     111 ;
     112 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D  ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
     113 .N OCXMON
     114 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
     115 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
     116 .E  S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
     117 ;
     118 I $L(OCXDT),'OCXDT D  ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
     119 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
     120 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
     121 ;
     122 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT)  ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
     123 ;
     124 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT)   ; INTERNAL FILEMAN FORMAT TO $H FORMAT
     125 ;
     126 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2)     ;  $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
     127 ;
     128 Q OCXVAL
     129 ;
     130FLAB(DFN,OCXLIST,OCXSPEC) ;  Compiler Function: FORMATTED LAB RESULTS
     131 ;
     132 Q:'$G(DFN) "<Patient Not Specified>"
     133 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
     134 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
     135 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
     136 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
     137 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
     138 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
     139 .S OCXX="",TEST=0 F  S TEST=$O(OCXTL(TEST)) Q:'TEST  D
     140 ..I $L($G(OCXSL)) D
     141 ...S SPEC=0 F  S SPEC=$O(OCXSL(SPEC)) Q:'SPEC  D
     142 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
     143 .....S OCXA($P(OCXX,U,7))=OCXX
     144 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
     145 ..Q:'$L(OCXX)
     146 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
     147 .I $L(OCXX) D
     148 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
     149 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
     150 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
     151 .S:$L(OCXOUT) OCXOUT=OCXOUT_"   " S OCXOUT=OCXOUT_$G(OCXY)
     152 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
     153 ;
     154GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     155 ;
     156 N OCXE,VAL,PC S VAL=""
     157 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     158 Q VAL
     159 ;
     160MCE73() ; Verify Event/Element: CREATININE CLEARANCE ESTIMATE
     161 ;
     162 ;  OCXDF(37) -> PATIENT IEN data field
     163 ;
     164 N OCXRES
     165 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(73,37)=OCXDF(37)
     166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),73)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),73))
     167 Q 0
     168 ;
     169MCE96() ; Verify Event/Element: CREATININE CLEARANCE DATE/TIME
     170 ;
     171 ;  OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field
     172 ;  OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field
     173 ;  OCXDF(77) -> CREATININE CLEARANCE (ESTIM) DATE data field
     174 ;  OCXDF(37) -> PATIENT IEN data field
     175 ;
     176 N OCXRES
     177 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(96,37)=OCXDF(37)
     178 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),96)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),96))
     179 S OCXRES(96)=0,OCXDF(77)=$$DT2INT($P($$CRCL(OCXDF(37)),"^",1)) I $L(OCXDF(77)) S OCXRES(96,77)=OCXDF(77) I (OCXDF(77)>$$DT2INT(0))
     180 E  Q 0
     181 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(96)=11 M ^TMP("OCXCHK",$J,OCXDF(37),96)=OCXRES(96)
     182 Q +OCXRES(96)
     183 ;
     184MCE97() ; Verify Event/Element: RENAL RESULTS
     185 ;
     186 ;  OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field
     187 ;  OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field
     188 ;  OCXDF(37) -> PATIENT IEN data field
     189 ;
     190 N OCXRES
     191 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(97,37)=OCXDF(37)
     192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),97)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),97))
     193 S OCXRES(97)=0,OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") I '(OCXDF(64)="<Results Not Found>")
     194 E  Q 0
     195 S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(97)=11 M ^TMP("OCXCHK",$J,OCXDF(37),97)=OCXRES(97)
     196 Q +OCXRES(97)
     197 ;
     198TERMLKUP(OCXTERM,OCXLIST) ;
     199 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
     200 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m

    r613 r623  
    1 OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R62R1A  ; Verify all Event/Elements of  Rule #62 'FOOD/DRUG INTERACTION'  Relation #1 'INPATIENT FOOD DRUG REACTION'
    14         ;  Called from EL84+5^OCXOZ0I.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE84( ----------->  Verify Event/Element: 'INPATIENT FOOD-DRUG REACTION'
    20         ;
    21         Q:$G(^OCXS(860.2,62,"INACT"))
    22         ;
    23         I $$MCE84 D R62R1B
    24         Q
    25         ;
    26 R62R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #62 'FOOD/DRUG INTERACTION'  Relation #1 'INPATIENT FOOD DRUG REACTION'
    27         ;  Called from R62R1A+10.
    28         ;
    29         Q:$G(OCXOERR)
    30         ;
    31         ;      Local Extrinsic Functions
    32         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    33         ; NEWRULE( ---------> NEW RULE MESSAGE
    34         ;
    35         Q:$D(OCXRULE("R62R1B"))
    36         ;
    37         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    38         S OCXCMSG=""
    39         S OCXNMSG="["_$$GETDATA(DFN,"84^",147)_"] "_$$GETDATA(DFN,"84^",82)_" ordered - adjust diet accordingly."
    40         ;
    41         Q:$G(OCXOERR)
    42         ;
    43         ; Send Notification
    44         ;
    45         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    46         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    47         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    48         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    49         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    50         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    51         .S OCXNUM=+$P(OCXORD,U,2)
    52         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    53         S OCXRULE("R62R1B")=""
    54         I $$NEWRULE(DFN,OCXNUM,62,1,55,OCXNMSG) D  I 1
    55         .D:($G(OCXTRACE)<5) EN^ORB3(55,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    56         Q
    57         ;
    58 R63R1A  ; Verify all Event/Elements of  Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'  Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...'
    59         ;  Called from EL91+5^OCXOZ0I, and EL106+5^OCXOZ0I.
    60         ;
    61         Q:$G(OCXOERR)
    62         ;
    63         ;      Local Extrinsic Functions
    64         ; MCE106( ---------->  Verify Event/Element: 'RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA'
    65         ; MCE91( ----------->  Verify Event/Element: 'PATIENT WITH GLUCOPHAGE MED'
    66         ;
    67         Q:$G(^OCXS(860.2,63,"INACT"))
    68         ;
    69         I $$MCE106 D
    70         .I $$MCE91 D R63R1B
    71         Q
    72         ;
    73 R63R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'  Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...'
    74         ;  Called from R63R1A+12.
    75         ;
    76         Q:$G(OCXOERR)
    77         ;
    78         Q:$D(OCXRULE("R63R1B"))
    79         ;
    80         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    81         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^23^^Procedure uses intravenous contrast media and patient is taking metformin." I 1
    82         E  S OCXCMSG="Procedure uses intravenous contrast media and patient is taking metformin."
    83         S OCXNMSG=""
    84         ;
    85         Q:$G(OCXOERR)
    86         ;
    87         ; Send Order Check Message
    88         ;
    89         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    90         Q
    91         ;
    92 R65R1A  ; Verify all Event/Elements of  Rule #65 'POLYPHARMACY'  Relation #1 'POLYPHARMACY'
    93         ;  Called from EL95+5^OCXOZ0I.
    94         ;
    95         Q:$G(OCXOERR)
    96         ;
    97         ;      Local Extrinsic Functions
    98         ; MCE95( ----------->  Verify Event/Element: 'POLYPHARMACY'
    99         ;
    100         Q:$G(^OCXS(860.2,65,"INACT"))
    101         ;
    102         I $$MCE95 D R65R1B
    103         Q
    104         ;
    105 R65R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #65 'POLYPHARMACY'  Relation #1 'POLYPHARMACY'
    106         ;  Called from R65R1A+10.
    107         ;
    108         Q:$G(OCXOERR)
    109         ;
    110         ;      Local Extrinsic Functions
    111         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    112         ;
    113         Q:$D(OCXRULE("R65R1B"))
    114         ;
    115         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    116         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^26^^Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." I 1
    117         E  S OCXCMSG="Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications."
    118         S OCXNMSG=""
    119         ;
    120         Q:$G(OCXOERR)
    121         ;
    122         ; Send Order Check Message
    123         ;
    124         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    125         Q
    126         ;
    127 R66R1A  ; Verify all Event/Elements of  Rule #66 'LAB RESULTS'  Relation #1 'HL7 LAB RESULTS'
    128         ;  Called from EL5+6^OCXOZ0H.
    129         ;
    130         Q:$G(OCXOERR)
    131         ;
    132         ;      Local Extrinsic Functions
    133         ; MCE5( ------------>  Verify Event/Element: 'HL7 FINAL LAB RESULT'
    134         ;
    135         Q:$G(^OCXS(860.2,66,"INACT"))
    136         ;
    137         I $$MCE5 D R66R1B^OCXOZ10
    138         Q
    139         ;
    140 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    141         ;
    142         N CKSUM,PTR,ASC S CKSUM=0
    143         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    144         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    145         Q +CKSUM
    146         ;
    147 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    148         ;
    149         N OCXE,VAL,PC S VAL=""
    150         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    151         Q VAL
    152         ;
    153 MCE106()        ; Verify Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA
    154         ;
    155         ;  OCXDF(37) -> PATIENT IEN data field
    156         ;
    157         N OCXRES
    158         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(106,37)=OCXDF(37)
    159         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),106)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),106))
    160         Q 0
    161         ;
    162 MCE5()  ; Verify Event/Element: HL7 FINAL LAB RESULT
    163         ;
    164         ;
    165         N OCXRES
    166         I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37)
    167         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5))
    168         Q 0
    169         ;
    170 MCE84() ; Verify Event/Element: INPATIENT FOOD-DRUG REACTION
    171         ;
    172         ;
    173         N OCXRES
    174         I $L(OCXDF(37)) S OCXRES(84,37)=OCXDF(37)
    175         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),84)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),84))
    176         Q 0
    177         ;
    178 MCE91() ; Verify Event/Element: PATIENT WITH GLUCOPHAGE MED
    179         ;
    180         ;  OCXDF(103) -> PATIENT CURRENTLY ON GLUCOPHAGE data field
    181         ;  OCXDF(37) -> PATIENT IEN data field
    182         ;
    183         N OCXRES
    184         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(91,37)=OCXDF(37)
    185         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),91)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),91))
    186         S OCXRES(91)=0,OCXDF(103)=$P($$TAKEMED^ORKPS(OCXDF(37),"^GLUCOPHAGE^METFORMIN^AVANDAMET^METAGLIP"),"^",1) I $L(OCXDF(103)) S OCXRES(91,103)=OCXDF(103) I (OCXDF(103))
    187         E  Q 0
    188         S OCXRES(91)=11 M ^TMP("OCXCHK",$J,OCXDF(37),91)=OCXRES(91)
    189         Q +OCXRES(91)
    190         ;
    191 MCE95() ; Verify Event/Element: POLYPHARMACY
    192         ;
    193         ;  OCXDF(37) -> PATIENT IEN data field
    194         ;
    195         N OCXRES
    196         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(95,37)=OCXDF(37)
    197         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),95)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),95))
    198         Q 0
    199         ;
    200 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    201         ;
    202         ;
    203         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    204         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    205         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    206         ;
    207         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    208         ;
    209         S OCXTIME=(+$H)
    210         S OCXCKSUM=$$CKSUM(OCXMESS)
    211         ;
    212         S OCXTSP=($H*86400)+$P($H,",",2)
    213         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    214         ;
    215         Q:(OCXTSPL>OCXTSP) 0
    216         ;
    217         K OCXDATA
    218         S OCXDATA(OCXDFN,0)=OCXDFN
    219         S OCXDATA("B",OCXDFN,OCXDFN)=""
    220         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    221         ;
    222         S OCXGR="^OCXD(860.7"
    223         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    224         ;
    225         K OCXDATA
    226         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    227         S OCXDATA(OCXRUL,"M")=OCXMESS
    228         S OCXDATA("B",OCXRUL,OCXRUL)=""
    229         S OCXGR=OCXGR_","_OCXDFN_",1"
    230         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    231         ;
    232         K OCXDATA
    233         S OCXDATA(OCXREL,0)=OCXREL
    234         S OCXDATA("B",OCXREL,OCXREL)=""
    235         S OCXGR=OCXGR_","_OCXRUL_",1"
    236         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    237         ;
    238         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    239         .;
    240         .N OCXGR1
    241         .S OCXGR1=OCXGR_","_OCXREL_",1"
    242         .K OCXDATA
    243         .S OCXDATA(OCXELE,0)=OCXELE
    244         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    245         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    246         .S OCXDATA("B",OCXELE,OCXELE)=""
    247         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    248         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    249         .;
    250         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    251         ..N OCXGR2
    252         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    253         ..K OCXDATA
    254         ..S OCXDATA(OCXDFI,0)=OCXDFI
    255         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    256         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    257         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    258         ;
    259         Q 1
    260         ;
    261 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    262         M @ROOT=DATA
    263         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    264         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    265         ;
    266         Q
    267         ;
    268         ;
     1OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R62R1A ; Verify all Event/Elements of  Rule #62 'FOOD/DRUG INTERACTION'  Relation #1 'INPATIENT FOOD DRUG REACTION'
     14 ;  Called from EL84+5^OCXOZ0I.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE84( ----------->  Verify Event/Element: 'INPATIENT FOOD-DRUG REACTION'
     20 ;
     21 Q:$G(^OCXS(860.2,62,"INACT"))
     22 ;
     23 I $$MCE84 D R62R1B
     24 Q
     25 ;
     26R62R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #62 'FOOD/DRUG INTERACTION'  Relation #1 'INPATIENT FOOD DRUG REACTION'
     27 ;  Called from R62R1A+10.
     28 ;
     29 Q:$G(OCXOERR)
     30 ;
     31 ;      Local Extrinsic Functions
     32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     33 ; NEWRULE( ---------> NEW RULE MESSAGE
     34 ;
     35 Q:$D(OCXRULE("R62R1B"))
     36 ;
     37 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     38 S OCXCMSG=""
     39 S OCXNMSG="["_$$GETDATA(DFN,"84^",147)_"] "_$$GETDATA(DFN,"84^",82)_" ordered - adjust diet accordingly."
     40 ;
     41 Q:$G(OCXOERR)
     42 ;
     43 ; Send Notification
     44 ;
     45 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     46 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     47 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     48 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     49 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     50 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     51 .S OCXNUM=+$P(OCXORD,U,2)
     52 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     53 S OCXRULE("R62R1B")=""
     54 I $$NEWRULE(DFN,OCXNUM,62,1,55,OCXNMSG) D  I 1
     55 .D:($G(OCXTRACE)<5) EN^ORB3(55,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     56 Q
     57 ;
     58R63R1A ; Verify all Event/Elements of  Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'  Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...'
     59 ;  Called from EL91+5^OCXOZ0I, and EL106+5^OCXOZ0I.
     60 ;
     61 Q:$G(OCXOERR)
     62 ;
     63 ;      Local Extrinsic Functions
     64 ; MCE106( ---------->  Verify Event/Element: 'RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA'
     65 ; MCE91( ----------->  Verify Event/Element: 'PATIENT WITH GLUCOPHAGE MED'
     66 ;
     67 Q:$G(^OCXS(860.2,63,"INACT"))
     68 ;
     69 I $$MCE106 D
     70 .I $$MCE91 D R63R1B
     71 Q
     72 ;
     73R63R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #63 'GLUCOPHAGE - CONTRAST MEDIA'  Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...'
     74 ;  Called from R63R1A+12.
     75 ;
     76 Q:$G(OCXOERR)
     77 ;
     78 Q:$D(OCXRULE("R63R1B"))
     79 ;
     80 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     81 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^23^^Procedure uses intravenous contrast media and patient is taking metformin." I 1
     82 E  S OCXCMSG="Procedure uses intravenous contrast media and patient is taking metformin."
     83 S OCXNMSG=""
     84 ;
     85 Q:$G(OCXOERR)
     86 ;
     87 ; Send Order Check Message
     88 ;
     89 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     90 Q
     91 ;
     92R65R1A ; Verify all Event/Elements of  Rule #65 'POLYPHARMACY'  Relation #1 'POLYPHARMACY'
     93 ;  Called from EL95+5^OCXOZ0I.
     94 ;
     95 Q:$G(OCXOERR)
     96 ;
     97 ;      Local Extrinsic Functions
     98 ; MCE95( ----------->  Verify Event/Element: 'POLYPHARMACY'
     99 ;
     100 Q:$G(^OCXS(860.2,65,"INACT"))
     101 ;
     102 I $$MCE95 D R65R1B
     103 Q
     104 ;
     105R65R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #65 'POLYPHARMACY'  Relation #1 'POLYPHARMACY'
     106 ;  Called from R65R1A+10.
     107 ;
     108 Q:$G(OCXOERR)
     109 ;
     110 ;      Local Extrinsic Functions
     111 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     112 ;
     113 Q:$D(OCXRULE("R65R1B"))
     114 ;
     115 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     116 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^26^^Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." I 1
     117 E  S OCXCMSG="Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications."
     118 S OCXNMSG=""
     119 ;
     120 Q:$G(OCXOERR)
     121 ;
     122 ; Send Order Check Message
     123 ;
     124 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     125 Q
     126 ;
     127R66R1A ; Verify all Event/Elements of  Rule #66 'LAB RESULTS'  Relation #1 'HL7 LAB RESULTS'
     128 ;  Called from EL5+6^OCXOZ0H.
     129 ;
     130 Q:$G(OCXOERR)
     131 ;
     132 ;      Local Extrinsic Functions
     133 ; MCE5( ------------>  Verify Event/Element: 'HL7 FINAL LAB RESULT'
     134 ;
     135 Q:$G(^OCXS(860.2,66,"INACT"))
     136 ;
     137 I $$MCE5 D R66R1B^OCXOZ10
     138 Q
     139 ;
     140CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     141 ;
     142 N CKSUM,PTR,ASC S CKSUM=0
     143 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     144 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     145 Q +CKSUM
     146 ;
     147GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     148 ;
     149 N OCXE,VAL,PC S VAL=""
     150 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     151 Q VAL
     152 ;
     153MCE106() ; Verify Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA
     154 ;
     155 ;  OCXDF(37) -> PATIENT IEN data field
     156 ;
     157 N OCXRES
     158 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(106,37)=OCXDF(37)
     159 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),106)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),106))
     160 Q 0
     161 ;
     162MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT
     163 ;
     164 ;
     165 N OCXRES
     166 I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37)
     167 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5))
     168 Q 0
     169 ;
     170MCE84() ; Verify Event/Element: INPATIENT FOOD-DRUG REACTION
     171 ;
     172 ;
     173 N OCXRES
     174 I $L(OCXDF(37)) S OCXRES(84,37)=OCXDF(37)
     175 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),84)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),84))
     176 Q 0
     177 ;
     178MCE91() ; Verify Event/Element: PATIENT WITH GLUCOPHAGE MED
     179 ;
     180 ;  OCXDF(103) -> PATIENT CURRENTLY ON GLUCOPHAGE data field
     181 ;  OCXDF(37) -> PATIENT IEN data field
     182 ;
     183 N OCXRES
     184 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(91,37)=OCXDF(37)
     185 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),91)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),91))
     186 S OCXRES(91)=0,OCXDF(103)=$P($$TAKEMED^ORKPS(OCXDF(37),"^GLUCOPHAGE^METFORMIN^AVANDAMET^METAGLIP"),"^",1) I $L(OCXDF(103)) S OCXRES(91,103)=OCXDF(103) I (OCXDF(103))
     187 E  Q 0
     188 S OCXRES(91)=11 M ^TMP("OCXCHK",$J,OCXDF(37),91)=OCXRES(91)
     189 Q +OCXRES(91)
     190 ;
     191MCE95() ; Verify Event/Element: POLYPHARMACY
     192 ;
     193 ;  OCXDF(37) -> PATIENT IEN data field
     194 ;
     195 N OCXRES
     196 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(95,37)=OCXDF(37)
     197 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),95)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),95))
     198 Q 0
     199 ;
     200NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     201 ;
     202 ;
     203 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     204 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     205 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     206 ;
     207 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     208 ;
     209 S OCXTIME=(+$H)
     210 S OCXCKSUM=$$CKSUM(OCXMESS)
     211 ;
     212 S OCXTSP=($H*86400)+$P($H,",",2)
     213 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     214 ;
     215 Q:(OCXTSPL>OCXTSP) 0
     216 ;
     217 K OCXDATA
     218 S OCXDATA(OCXDFN,0)=OCXDFN
     219 S OCXDATA("B",OCXDFN,OCXDFN)=""
     220 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     221 ;
     222 S OCXGR="^OCXD(860.7"
     223 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     224 ;
     225 K OCXDATA
     226 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     227 S OCXDATA(OCXRUL,"M")=OCXMESS
     228 S OCXDATA("B",OCXRUL,OCXRUL)=""
     229 S OCXGR=OCXGR_","_OCXDFN_",1"
     230 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     231 ;
     232 K OCXDATA
     233 S OCXDATA(OCXREL,0)=OCXREL
     234 S OCXDATA("B",OCXREL,OCXREL)=""
     235 S OCXGR=OCXGR_","_OCXRUL_",1"
     236 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     237 ;
     238 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     239 .;
     240 .N OCXGR1
     241 .S OCXGR1=OCXGR_","_OCXREL_",1"
     242 .K OCXDATA
     243 .S OCXDATA(OCXELE,0)=OCXELE
     244 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     245 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     246 .S OCXDATA("B",OCXELE,OCXELE)=""
     247 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     248 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     249 .;
     250 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     251 ..N OCXGR2
     252 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     253 ..K OCXDATA
     254 ..S OCXDATA(OCXDFI,0)=OCXDFI
     255 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     256 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     257 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     258 ;
     259 Q 1
     260 ;
     261SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     262 M @ROOT=DATA
     263 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     264 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     265 ;
     266 Q
     267 ;
     268 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m

    r613 r623  
    1 OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R66R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #66 'LAB RESULTS'  Relation #1 'HL7 LAB RESULTS'
    14         ;  Called from R66R1A+10^OCXOZ0Z.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; NEWRULE( ---------> NEW RULE MESSAGE
    21         ;
    22         Q:$D(OCXRULE("R66R1B"))
    23         ;
    24         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    25         S OCXCMSG=""
    26         S OCXNMSG="Labs resulted - ["_$$GETDATA(DFN,"5^",96)_"]"
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Notification
    31         ;
    32         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    33         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    34         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    35         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    36         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    37         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    38         .S OCXNUM=+$P(OCXORD,U,2)
    39         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    40         S OCXRULE("R66R1B")=""
    41         I $$NEWRULE(DFN,OCXNUM,66,1,3,OCXNMSG) D  I 1
    42         .D:($G(OCXTRACE)<5) EN^ORB3(3,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    43         Q
    44         ;
    45 R67R1A  ; Verify all Event/Elements of  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5'
    46         ;  Called from EL86+5^OCXOZ0I, and EL111+5^OCXOZ0I.
    47         ;
    48         Q:$G(OCXOERR)
    49         ;
    50         ;      Local Extrinsic Functions
    51         ; MCE111( ---------->  Verify Event/Element: 'GLUCOPHAGE CREATININE > 1.5'
    52         ; MCE86( ----------->  Verify Event/Element: 'GLUCOPHAGE ORDER'
    53         ;
    54         Q:$G(^OCXS(860.2,67,"INACT"))
    55         ;
    56         I $$MCE86 D
    57         .I $$MCE111 D R67R1B
    58         Q
    59         ;
    60 R67R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5'
    61         ;  Called from R67R1A+12.
    62         ;
    63         Q:$G(OCXOERR)
    64         ;
    65         ;      Local Extrinsic Functions
    66         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    67         ;
    68         Q:$D(OCXRULE("R67R1B"))
    69         ;
    70         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    71         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) I 1
    72         E  S OCXCMSG="Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125)
    73         S OCXNMSG=""
    74         ;
    75         Q:$G(OCXOERR)
    76         ;
    77         ; Send Order Check Message
    78         ;
    79         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    80         Q
    81         ;
    82 R67R2A  ; Verify all Event/Elements of  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE'
    83         ;  Called from EL86+6^OCXOZ0I, and EL112+5^OCXOZ0I.
    84         ;
    85         Q:$G(OCXOERR)
    86         ;
    87         ;      Local Extrinsic Functions
    88         ; MCE112( ---------->  Verify Event/Element: 'NO GLUCOPHAGE CREATININE'
    89         ; MCE86( ----------->  Verify Event/Element: 'GLUCOPHAGE ORDER'
    90         ;
    91         Q:$G(^OCXS(860.2,67,"INACT"))
    92         ;
    93         I $$MCE86 D
    94         .I $$MCE112 D R67R2B
    95         Q
    96         ;
    97 R67R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE'
    98         ;  Called from R67R2A+12.
    99         ;
    100         Q:$G(OCXOERR)
    101         ;
    102         ;      Local Extrinsic Functions
    103         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    104         ;
    105         Q:$D(OCXRULE("R67R2B"))
    106         ;
    107         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    108         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." I 1
    109         E  S OCXCMSG="Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days."
    110         S OCXNMSG=""
    111         ;
    112         Q:$G(OCXOERR)
    113         ;
    114         ; Send Order Check Message
    115         ;
    116         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    117         Q
    118         ;
    119 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    120         ;
    121         N CKSUM,PTR,ASC S CKSUM=0
    122         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    123         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    124         Q +CKSUM
    125         ;
    126 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    127         ;
    128         N OCXE,VAL,PC S VAL=""
    129         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    130         Q VAL
    131         ;
    132 MCE111()        ; Verify Event/Element: GLUCOPHAGE CREATININE > 1.5
    133         ;
    134         ;  OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field
    135         ;  OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field
    136         ;  OCXDF(126) -> RECENT GLUCOPHAGE CREATININE RESULT data field
    137         ;  OCXDF(37) -> PATIENT IEN data field
    138         ;
    139         N OCXRES
    140         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(111,37)=OCXDF(37)
    141         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),111)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),111))
    142         S OCXRES(111)=0,OCXDF(126)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",3) I $L(OCXDF(126)) S OCXRES(111,126)=OCXDF(126) I (OCXDF(126)>1.5)
    143         E  Q 0
    144         S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(111)=11 M ^TMP("OCXCHK",$J,OCXDF(37),111)=OCXRES(111)
    145         Q +OCXRES(111)
    146         ;
    147 MCE112()        ; Verify Event/Element: NO GLUCOPHAGE CREATININE
    148         ;
    149         ;  OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field
    150         ;  OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field
    151         ;  OCXDF(124) -> RECENT GLUCOPHAGE CREATININE FLAG data field
    152         ;  OCXDF(37) -> PATIENT IEN data field
    153         ;
    154         N OCXRES
    155         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(112,37)=OCXDF(37)
    156         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),112)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),112))
    157         S OCXRES(112)=0,OCXDF(124)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(124)) S OCXRES(112,124)=OCXDF(124) I '(OCXDF(124))
    158         E  Q 0
    159         S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(112)=11 M ^TMP("OCXCHK",$J,OCXDF(37),112)=OCXRES(112)
    160         Q +OCXRES(112)
    161         ;
    162 MCE86() ; Verify Event/Element: GLUCOPHAGE ORDER
    163         ;
    164         ;  OCXDF(37) -> PATIENT IEN data field
    165         ;
    166         N OCXRES
    167         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(86,37)=OCXDF(37)
    168         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),86)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),86))
    169         Q 0
    170         ;
    171 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    172         ;
    173         ;
    174         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    175         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    176         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    177         ;
    178         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    179         ;
    180         S OCXTIME=(+$H)
    181         S OCXCKSUM=$$CKSUM(OCXMESS)
    182         ;
    183         S OCXTSP=($H*86400)+$P($H,",",2)
    184         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    185         ;
    186         Q:(OCXTSPL>OCXTSP) 0
    187         ;
    188         K OCXDATA
    189         S OCXDATA(OCXDFN,0)=OCXDFN
    190         S OCXDATA("B",OCXDFN,OCXDFN)=""
    191         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    192         ;
    193         S OCXGR="^OCXD(860.7"
    194         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    195         ;
    196         K OCXDATA
    197         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    198         S OCXDATA(OCXRUL,"M")=OCXMESS
    199         S OCXDATA("B",OCXRUL,OCXRUL)=""
    200         S OCXGR=OCXGR_","_OCXDFN_",1"
    201         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    202         ;
    203         K OCXDATA
    204         S OCXDATA(OCXREL,0)=OCXREL
    205         S OCXDATA("B",OCXREL,OCXREL)=""
    206         S OCXGR=OCXGR_","_OCXRUL_",1"
    207         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    208         ;
    209         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    210         .;
    211         .N OCXGR1
    212         .S OCXGR1=OCXGR_","_OCXREL_",1"
    213         .K OCXDATA
    214         .S OCXDATA(OCXELE,0)=OCXELE
    215         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    216         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    217         .S OCXDATA("B",OCXELE,OCXELE)=""
    218         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    219         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    220         .;
    221         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    222         ..N OCXGR2
    223         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    224         ..K OCXDATA
    225         ..S OCXDATA(OCXDFI,0)=OCXDFI
    226         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    227         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    228         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    229         ;
    230         Q 1
    231         ;
    232 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    233         M @ROOT=DATA
    234         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    235         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    236         ;
    237         Q
    238         ;
    239         ;
     1OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R66R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #66 'LAB RESULTS'  Relation #1 'HL7 LAB RESULTS'
     14 ;  Called from R66R1A+10^OCXOZ0Z.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; NEWRULE( ---------> NEW RULE MESSAGE
     21 ;
     22 Q:$D(OCXRULE("R66R1B"))
     23 ;
     24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     25 S OCXCMSG=""
     26 S OCXNMSG="Labs resulted - ["_$$GETDATA(DFN,"5^",96)_"]"
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Notification
     31 ;
     32 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     38 .S OCXNUM=+$P(OCXORD,U,2)
     39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     40 S OCXRULE("R66R1B")=""
     41 I $$NEWRULE(DFN,OCXNUM,66,1,3,OCXNMSG) D  I 1
     42 .D:($G(OCXTRACE)<5) EN^ORB3(3,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     43 Q
     44 ;
     45R67R1A ; Verify all Event/Elements of  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5'
     46 ;  Called from EL86+5^OCXOZ0I, and EL111+5^OCXOZ0I.
     47 ;
     48 Q:$G(OCXOERR)
     49 ;
     50 ;      Local Extrinsic Functions
     51 ; MCE111( ---------->  Verify Event/Element: 'GLUCOPHAGE CREATININE > 1.5'
     52 ; MCE86( ----------->  Verify Event/Element: 'GLUCOPHAGE ORDER'
     53 ;
     54 Q:$G(^OCXS(860.2,67,"INACT"))
     55 ;
     56 I $$MCE86 D
     57 .I $$MCE111 D R67R1B
     58 Q
     59 ;
     60R67R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5'
     61 ;  Called from R67R1A+12.
     62 ;
     63 Q:$G(OCXOERR)
     64 ;
     65 ;      Local Extrinsic Functions
     66 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     67 ;
     68 Q:$D(OCXRULE("R67R1B"))
     69 ;
     70 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     71 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) I 1
     72 E  S OCXCMSG="Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125)
     73 S OCXNMSG=""
     74 ;
     75 Q:$G(OCXOERR)
     76 ;
     77 ; Send Order Check Message
     78 ;
     79 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     80 Q
     81 ;
     82R67R2A ; Verify all Event/Elements of  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE'
     83 ;  Called from EL86+6^OCXOZ0I, and EL112+5^OCXOZ0I.
     84 ;
     85 Q:$G(OCXOERR)
     86 ;
     87 ;      Local Extrinsic Functions
     88 ; MCE112( ---------->  Verify Event/Element: 'NO GLUCOPHAGE CREATININE'
     89 ; MCE86( ----------->  Verify Event/Element: 'GLUCOPHAGE ORDER'
     90 ;
     91 Q:$G(^OCXS(860.2,67,"INACT"))
     92 ;
     93 I $$MCE86 D
     94 .I $$MCE112 D R67R2B
     95 Q
     96 ;
     97R67R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #67 'GLUCOPHAGE - LAB RESULTS'  Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE'
     98 ;  Called from R67R2A+12.
     99 ;
     100 Q:$G(OCXOERR)
     101 ;
     102 ;      Local Extrinsic Functions
     103 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     104 ;
     105 Q:$D(OCXRULE("R67R2B"))
     106 ;
     107 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     108 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." I 1
     109 E  S OCXCMSG="Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days."
     110 S OCXNMSG=""
     111 ;
     112 Q:$G(OCXOERR)
     113 ;
     114 ; Send Order Check Message
     115 ;
     116 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     117 Q
     118 ;
     119CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     120 ;
     121 N CKSUM,PTR,ASC S CKSUM=0
     122 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     123 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     124 Q +CKSUM
     125 ;
     126GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     127 ;
     128 N OCXE,VAL,PC S VAL=""
     129 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     130 Q VAL
     131 ;
     132MCE111() ; Verify Event/Element: GLUCOPHAGE CREATININE > 1.5
     133 ;
     134 ;  OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field
     135 ;  OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field
     136 ;  OCXDF(126) -> RECENT GLUCOPHAGE CREATININE RESULT data field
     137 ;  OCXDF(37) -> PATIENT IEN data field
     138 ;
     139 N OCXRES
     140 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(111,37)=OCXDF(37)
     141 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),111)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),111))
     142 S OCXRES(111)=0,OCXDF(126)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",3) I $L(OCXDF(126)) S OCXRES(111,126)=OCXDF(126) I (OCXDF(126)>1.5)
     143 E  Q 0
     144 S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(111)=11 M ^TMP("OCXCHK",$J,OCXDF(37),111)=OCXRES(111)
     145 Q +OCXRES(111)
     146 ;
     147MCE112() ; Verify Event/Element: NO GLUCOPHAGE CREATININE
     148 ;
     149 ;  OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field
     150 ;  OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field
     151 ;  OCXDF(124) -> RECENT GLUCOPHAGE CREATININE FLAG data field
     152 ;  OCXDF(37) -> PATIENT IEN data field
     153 ;
     154 N OCXRES
     155 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(112,37)=OCXDF(37)
     156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),112)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),112))
     157 S OCXRES(112)=0,OCXDF(124)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(124)) S OCXRES(112,124)=OCXDF(124) I '(OCXDF(124))
     158 E  Q 0
     159 S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(112)=11 M ^TMP("OCXCHK",$J,OCXDF(37),112)=OCXRES(112)
     160 Q +OCXRES(112)
     161 ;
     162MCE86() ; Verify Event/Element: GLUCOPHAGE ORDER
     163 ;
     164 ;  OCXDF(37) -> PATIENT IEN data field
     165 ;
     166 N OCXRES
     167 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(86,37)=OCXDF(37)
     168 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),86)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),86))
     169 Q 0
     170 ;
     171NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     172 ;
     173 ;
     174 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     175 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     176 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     177 ;
     178 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     179 ;
     180 S OCXTIME=(+$H)
     181 S OCXCKSUM=$$CKSUM(OCXMESS)
     182 ;
     183 S OCXTSP=($H*86400)+$P($H,",",2)
     184 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     185 ;
     186 Q:(OCXTSPL>OCXTSP) 0
     187 ;
     188 K OCXDATA
     189 S OCXDATA(OCXDFN,0)=OCXDFN
     190 S OCXDATA("B",OCXDFN,OCXDFN)=""
     191 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     192 ;
     193 S OCXGR="^OCXD(860.7"
     194 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     195 ;
     196 K OCXDATA
     197 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     198 S OCXDATA(OCXRUL,"M")=OCXMESS
     199 S OCXDATA("B",OCXRUL,OCXRUL)=""
     200 S OCXGR=OCXGR_","_OCXDFN_",1"
     201 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     202 ;
     203 K OCXDATA
     204 S OCXDATA(OCXREL,0)=OCXREL
     205 S OCXDATA("B",OCXREL,OCXREL)=""
     206 S OCXGR=OCXGR_","_OCXRUL_",1"
     207 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     208 ;
     209 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     210 .;
     211 .N OCXGR1
     212 .S OCXGR1=OCXGR_","_OCXREL_",1"
     213 .K OCXDATA
     214 .S OCXDATA(OCXELE,0)=OCXELE
     215 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     216 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     217 .S OCXDATA("B",OCXELE,OCXELE)=""
     218 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     219 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     220 .;
     221 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     222 ..N OCXGR2
     223 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     224 ..K OCXDATA
     225 ..S OCXDATA(OCXDFI,0)=OCXDFI
     226 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     227 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     228 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     229 ;
     230 Q 1
     231 ;
     232SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     233 M @ROOT=DATA
     234 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     235 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     236 ;
     237 Q
     238 ;
     239 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m

    r613 r623  
    1 OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R68R1A  ; Verify all Event/Elements of  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE'
    14         ;  Called from EL122+5^OCXOZ0I, and EL125+5^OCXOZ0I.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE122( ---------->  Verify Event/Element: 'AMITRIPTYLINE ORDER'
    20         ; MCE125( ---------->  Verify Event/Element: 'MED ORDER FOR PT > 64'
    21         ;
    22         Q:$G(^OCXS(860.2,68,"INACT"))
    23         ;
    24         I $$MCE125 D
    25         .I $$MCE122 D R68R1B
    26         Q
    27         ;
    28 R68R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE'
    29         ;  Called from R68R1A+12.
    30         ;
    31         Q:$G(OCXOERR)
    32         ;
    33         ;      Local Extrinsic Functions
    34         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    35         ;
    36         Q:$D(OCXRULE("R68R1B"))
    37         ;
    38         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    39         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) I 1
    40         E  S OCXCMSG="Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141)
    41         S OCXNMSG=""
    42         ;
    43         Q:$G(OCXOERR)
    44         ;
    45         ; Send Order Check Message
    46         ;
    47         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    48         Q
    49         ;
    50 R68R2A  ; Verify all Event/Elements of  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE'
    51         ;  Called from EL125+6^OCXOZ0I, and EL123+5^OCXOZ0I.
    52         ;
    53         Q:$G(OCXOERR)
    54         ;
    55         ;      Local Extrinsic Functions
    56         ; MCE123( ---------->  Verify Event/Element: 'CHLORPROPAMIDE ORDER'
    57         ; MCE125( ---------->  Verify Event/Element: 'MED ORDER FOR PT > 64'
    58         ;
    59         Q:$G(^OCXS(860.2,68,"INACT"))
    60         ;
    61         I $$MCE125 D
    62         .I $$MCE123 D R68R2B
    63         Q
    64         ;
    65 R68R2B  ; Send Order Check, Notication messages and/or Execute code for  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE'
    66         ;  Called from R68R2A+12.
    67         ;
    68         Q:$G(OCXOERR)
    69         ;
    70         ;      Local Extrinsic Functions
    71         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    72         ;
    73         Q:$D(OCXRULE("R68R2B"))
    74         ;
    75         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    76         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) I 1
    77         E  S OCXCMSG="Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142)
    78         S OCXNMSG=""
    79         ;
    80         Q:$G(OCXOERR)
    81         ;
    82         ; Send Order Check Message
    83         ;
    84         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    85         Q
    86         ;
    87 R68R3A  ; Verify all Event/Elements of  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE'
    88         ;  Called from EL125+7^OCXOZ0I, and EL124+5^OCXOZ0I.
    89         ;
    90         Q:$G(OCXOERR)
    91         ;
    92         ;      Local Extrinsic Functions
    93         ; MCE124( ---------->  Verify Event/Element: 'DIPYRIDAMOLE ORDER'
    94         ; MCE125( ---------->  Verify Event/Element: 'MED ORDER FOR PT > 64'
    95         ;
    96         Q:$G(^OCXS(860.2,68,"INACT"))
    97         ;
    98         I $$MCE125 D
    99         .I $$MCE124 D R68R3B
    100         Q
    101         ;
    102 R68R3B  ; Send Order Check, Notication messages and/or Execute code for  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE'
    103         ;  Called from R68R3A+12.
    104         ;
    105         Q:$G(OCXOERR)
    106         ;
    107         ;      Local Extrinsic Functions
    108         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    109         ;
    110         Q:$D(OCXRULE("R68R3B"))
    111         ;
    112         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    113         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"124^125",62)_".  "_$$GETDATA(DFN,"124^125",144) I 1
    114         E  S OCXCMSG="Patient is "_$$GETDATA(DFN,"124^125",62)_".  "_$$GETDATA(DFN,"124^125",144)
    115         S OCXNMSG=""
    116         ;
    117         Q:$G(OCXOERR)
    118         ;
    119         ; Send Order Check Message
    120         ;
    121         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    122         Q
    123         ;
    124 R69R1A  ; Verify all Event/Elements of  Rule #69 'LAB THRESHOLD'  Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...'
    125         ;  Called from EL5+7^OCXOZ0H, and EL131+5^OCXOZ0I, and EL132+5^OCXOZ0I.
    126         ;
    127         Q:$G(OCXOERR)
    128         ;
    129         ;      Local Extrinsic Functions
    130         ; MCE131( ---------->  Verify Event/Element: 'GREATER THAN LAB THRESHOLD'
    131         ; MCE132( ---------->  Verify Event/Element: 'LESS THAN LAB THRESHOLD'
    132         ; MCE5( ------------>  Verify Event/Element: 'HL7 FINAL LAB RESULT'
    133         ;
    134         Q:$G(^OCXS(860.2,69,"INACT"))
    135         ;
    136         I $$MCE5 D
    137         .I $$MCE131 D R69R1B^OCXOZ12
    138         .I $$MCE132 D R69R1B^OCXOZ12
    139         Q
    140         ;
    141 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    142         ;
    143         N OCXE,VAL,PC S VAL=""
    144         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    145         Q VAL
    146         ;
    147 MCE122()        ; Verify Event/Element: AMITRIPTYLINE ORDER
    148         ;
    149         ;  OCXDF(37) -> PATIENT IEN data field
    150         ;
    151         N OCXRES
    152         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(122,37)=OCXDF(37)
    153         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),122)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),122))
    154         Q 0
    155         ;
    156 MCE123()        ; Verify Event/Element: CHLORPROPAMIDE ORDER
    157         ;
    158         ;  OCXDF(37) -> PATIENT IEN data field
    159         ;
    160         N OCXRES
    161         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(123,37)=OCXDF(37)
    162         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),123)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),123))
    163         Q 0
    164         ;
    165 MCE124()        ; Verify Event/Element: DIPYRIDAMOLE ORDER
    166         ;
    167         ;  OCXDF(37) -> PATIENT IEN data field
    168         ;
    169         N OCXRES
    170         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(124,37)=OCXDF(37)
    171         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),124)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),124))
    172         Q 0
    173         ;
    174 MCE125()        ; Verify Event/Element: MED ORDER FOR PT > 64
    175         ;
    176         ;  OCXDF(37) -> PATIENT IEN data field
    177         ;
    178         N OCXRES
    179         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(125,37)=OCXDF(37)
    180         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),125)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),125))
    181         Q 0
    182         ;
    183 MCE131()        ; Verify Event/Element: GREATER THAN LAB THRESHOLD
    184         ;
    185         ;
    186         N OCXRES
    187         I $L(OCXDF(37)) S OCXRES(131,37)=OCXDF(37)
    188         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),131)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),131))
    189         Q 0
    190         ;
    191 MCE132()        ; Verify Event/Element: LESS THAN LAB THRESHOLD
    192         ;
    193         ;
    194         N OCXRES
    195         I $L(OCXDF(37)) S OCXRES(132,37)=OCXDF(37)
    196         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),132)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),132))
    197         Q 0
    198         ;
    199 MCE5()  ; Verify Event/Element: HL7 FINAL LAB RESULT
    200         ;
    201         ;
    202         N OCXRES
    203         I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37)
    204         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5))
    205         Q 0
    206         ;
     1OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R68R1A ; Verify all Event/Elements of  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE'
     14 ;  Called from EL122+5^OCXOZ0I, and EL125+5^OCXOZ0I.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE122( ---------->  Verify Event/Element: 'AMITRIPTYLINE ORDER'
     20 ; MCE125( ---------->  Verify Event/Element: 'MED ORDER FOR PT > 64'
     21 ;
     22 Q:$G(^OCXS(860.2,68,"INACT"))
     23 ;
     24 I $$MCE125 D
     25 .I $$MCE122 D R68R1B
     26 Q
     27 ;
     28R68R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE'
     29 ;  Called from R68R1A+12.
     30 ;
     31 Q:$G(OCXOERR)
     32 ;
     33 ;      Local Extrinsic Functions
     34 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     35 ;
     36 Q:$D(OCXRULE("R68R1B"))
     37 ;
     38 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     39 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) I 1
     40 E  S OCXCMSG="Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141)
     41 S OCXNMSG=""
     42 ;
     43 Q:$G(OCXOERR)
     44 ;
     45 ; Send Order Check Message
     46 ;
     47 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     48 Q
     49 ;
     50R68R2A ; Verify all Event/Elements of  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE'
     51 ;  Called from EL125+6^OCXOZ0I, and EL123+5^OCXOZ0I.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;      Local Extrinsic Functions
     56 ; MCE123( ---------->  Verify Event/Element: 'CHLORPROPAMIDE ORDER'
     57 ; MCE125( ---------->  Verify Event/Element: 'MED ORDER FOR PT > 64'
     58 ;
     59 Q:$G(^OCXS(860.2,68,"INACT"))
     60 ;
     61 I $$MCE125 D
     62 .I $$MCE123 D R68R2B
     63 Q
     64 ;
     65R68R2B ; Send Order Check, Notication messages and/or Execute code for  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE'
     66 ;  Called from R68R2A+12.
     67 ;
     68 Q:$G(OCXOERR)
     69 ;
     70 ;      Local Extrinsic Functions
     71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     72 ;
     73 Q:$D(OCXRULE("R68R2B"))
     74 ;
     75 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     76 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) I 1
     77 E  S OCXCMSG="Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142)
     78 S OCXNMSG=""
     79 ;
     80 Q:$G(OCXOERR)
     81 ;
     82 ; Send Order Check Message
     83 ;
     84 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     85 Q
     86 ;
     87R68R3A ; Verify all Event/Elements of  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE'
     88 ;  Called from EL125+7^OCXOZ0I, and EL124+5^OCXOZ0I.
     89 ;
     90 Q:$G(OCXOERR)
     91 ;
     92 ;      Local Extrinsic Functions
     93 ; MCE124( ---------->  Verify Event/Element: 'DIPYRIDAMOLE ORDER'
     94 ; MCE125( ---------->  Verify Event/Element: 'MED ORDER FOR PT > 64'
     95 ;
     96 Q:$G(^OCXS(860.2,68,"INACT"))
     97 ;
     98 I $$MCE125 D
     99 .I $$MCE124 D R68R3B
     100 Q
     101 ;
     102R68R3B ; Send Order Check, Notication messages and/or Execute code for  Rule #68 'DANGEROUS MEDS OVER AGE 64'  Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE'
     103 ;  Called from R68R3A+12.
     104 ;
     105 Q:$G(OCXOERR)
     106 ;
     107 ;      Local Extrinsic Functions
     108 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     109 ;
     110 Q:$D(OCXRULE("R68R3B"))
     111 ;
     112 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     113 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"124^125",62)_".  "_$$GETDATA(DFN,"124^125",144) I 1
     114 E  S OCXCMSG="Patient is "_$$GETDATA(DFN,"124^125",62)_".  "_$$GETDATA(DFN,"124^125",144)
     115 S OCXNMSG=""
     116 ;
     117 Q:$G(OCXOERR)
     118 ;
     119 ; Send Order Check Message
     120 ;
     121 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     122 Q
     123 ;
     124R69R1A ; Verify all Event/Elements of  Rule #69 'LAB THRESHOLD'  Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...'
     125 ;  Called from EL5+7^OCXOZ0H, and EL131+5^OCXOZ0I, and EL132+5^OCXOZ0I.
     126 ;
     127 Q:$G(OCXOERR)
     128 ;
     129 ;      Local Extrinsic Functions
     130 ; MCE131( ---------->  Verify Event/Element: 'GREATER THAN LAB THRESHOLD'
     131 ; MCE132( ---------->  Verify Event/Element: 'LESS THAN LAB THRESHOLD'
     132 ; MCE5( ------------>  Verify Event/Element: 'HL7 FINAL LAB RESULT'
     133 ;
     134 Q:$G(^OCXS(860.2,69,"INACT"))
     135 ;
     136 I $$MCE5 D
     137 .I $$MCE131 D R69R1B^OCXOZ12
     138 .I $$MCE132 D R69R1B^OCXOZ12
     139 Q
     140 ;
     141GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     142 ;
     143 N OCXE,VAL,PC S VAL=""
     144 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     145 Q VAL
     146 ;
     147MCE122() ; Verify Event/Element: AMITRIPTYLINE ORDER
     148 ;
     149 ;  OCXDF(37) -> PATIENT IEN data field
     150 ;
     151 N OCXRES
     152 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(122,37)=OCXDF(37)
     153 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),122)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),122))
     154 Q 0
     155 ;
     156MCE123() ; Verify Event/Element: CHLORPROPAMIDE ORDER
     157 ;
     158 ;  OCXDF(37) -> PATIENT IEN data field
     159 ;
     160 N OCXRES
     161 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(123,37)=OCXDF(37)
     162 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),123)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),123))
     163 Q 0
     164 ;
     165MCE124() ; Verify Event/Element: DIPYRIDAMOLE ORDER
     166 ;
     167 ;  OCXDF(37) -> PATIENT IEN data field
     168 ;
     169 N OCXRES
     170 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(124,37)=OCXDF(37)
     171 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),124)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),124))
     172 Q 0
     173 ;
     174MCE125() ; Verify Event/Element: MED ORDER FOR PT > 64
     175 ;
     176 ;  OCXDF(37) -> PATIENT IEN data field
     177 ;
     178 N OCXRES
     179 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(125,37)=OCXDF(37)
     180 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),125)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),125))
     181 Q 0
     182 ;
     183MCE131() ; Verify Event/Element: GREATER THAN LAB THRESHOLD
     184 ;
     185 ;
     186 N OCXRES
     187 I $L(OCXDF(37)) S OCXRES(131,37)=OCXDF(37)
     188 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),131)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),131))
     189 Q 0
     190 ;
     191MCE132() ; Verify Event/Element: LESS THAN LAB THRESHOLD
     192 ;
     193 ;
     194 N OCXRES
     195 I $L(OCXDF(37)) S OCXRES(132,37)=OCXDF(37)
     196 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),132)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),132))
     197 Q 0
     198 ;
     199MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT
     200 ;
     201 ;
     202 N OCXRES
     203 I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37)
     204 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5))
     205 Q 0
     206 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m

    r613 r623  
    1 OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R69R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #69 'LAB THRESHOLD'  Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...'
    14         ;  Called from R69R1A+13^OCXOZ11.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ; LABTHRSR( --------> LAB THRESHOLD EXCEEDED RESULTS
    21         ; NEWRULE( ---------> NEW RULE MESSAGE
    22         ;
    23         Q:$D(OCXRULE("R69R1B"))
    24         ;
    25         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    26         S OCXCMSG=""
    27         S OCXNMSG="["_$$GETDATA(DFN,"5^131^132",147)_"] Lab threshold exceeded - ["_$$GETDATA(DFN,"5^131^132",96)_"]"
    28         ;
    29         ;
    30         ; Run Execute Code
    31         ;
    32         S OCXTMP=$$LABTHRSR(.OCXDUZ,$$GETDATA(DFN,"5^131^132",113),$$GETDATA(DFN,"5^131^132",152),$$GETDATA(DFN,"5^131^132",12),$$GETDATA(DFN,"5^131^132",37))
    33         Q:$G(OCXOERR)
    34         ;
    35         ; Send Notification
    36         ;
    37         S (OCXDUZ,OCXDATA)="",OCXNUM=0
    38         I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
    39         .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
    40         .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
    41         I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
    42         .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
    43         .S OCXNUM=+$P(OCXORD,U,2)
    44         S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
    45         S OCXRULE("R69R1B")=""
    46         I $$NEWRULE(DFN,OCXNUM,69,1,68,OCXNMSG) D  I 1
    47         .D:($G(OCXTRACE)<5) EN^ORB3(68,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
    48         Q
    49         ;
    50 R70R1A  ; Verify all Event/Elements of  Rule #70 'NO ALLERGY ASSESSMENT'  Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...'
    51         ;  Called from EL28+5^OCXOZ0I, and EL135+5^OCXOZ0I, and EL136+5^OCXOZ0I, and EL137+5^OCXOZ0I.
    52         ;
    53         Q:$G(OCXOERR)
    54         ;
    55         ;      Local Extrinsic Functions
    56         ; MCE135( ---------->  Verify Event/Element: 'DIET ORDER'
    57         ; MCE136( ---------->  Verify Event/Element: 'NO ALLERGY ASSESSMENT'
    58         ; MCE137( ---------->  Verify Event/Element: 'PHARMACY ORDER'
    59         ; MCE28( ----------->  Verify Event/Element: 'RADIOLOGY ORDER'
    60         ;
    61         Q:$G(^OCXS(860.2,70,"INACT"))
    62         ;
    63         I $$MCE136 D
    64         .I $$MCE28 D R70R1B
    65         .I $$MCE137 D R70R1B
    66         .I $$MCE135 D R70R1B
    67         Q
    68         ;
    69 R70R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #70 'NO ALLERGY ASSESSMENT'  Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...'
    70         ;  Called from R70R1A+14.
    71         ;
    72         Q:$G(OCXOERR)
    73         ;
    74         ;      Local Extrinsic Functions
    75         ; NEWRULE( ---------> NEW RULE MESSAGE
    76         ;
    77         Q:$D(OCXRULE("R70R1B"))
    78         ;
    79         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    80         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^32^^Patient has no allergy assessment." I 1
    81         E  S OCXCMSG="Patient has no allergy assessment."
    82         S OCXNMSG=""
    83         ;
    84         ;
    85         ; Run Execute Code
    86         ;
    87         Q:'$$NEWRULE(DFN,$J,39,1,999,"Patient has no allergy assessment.")
    88         Q:$G(OCXOERR)
    89         ;
    90         ; Send Order Check Message
    91         ;
    92         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    93         Q
    94         ;
    95 CKSUM(STR)      ;  Compiler Function: GENERATE STRING CHECKSUM
    96         ;
    97         N CKSUM,PTR,ASC S CKSUM=0
    98         S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    99         F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
    100         Q +CKSUM
    101         ;
    102 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    103         ;
    104         N OCXE,VAL,PC S VAL=""
    105         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    106         Q VAL
    107         ;
    108 LABTHRSR(OCXDUZ,OCXLAB,OCXSPEC,OCXRSLT,OCXPTDFN)              ;  Compiler Function: LAB THRESHOLD EXCEEDED RESULTS
    109         ;
    110         Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT) 0
    111         ;
    112         N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXOP,OCXEXCD
    113         S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC
    114         F OCXOP="<",">" D
    115         .D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
    116         .Q:+$G(ORERR)'=0
    117         .Q:+$G(OCXX)=0
    118         .S OCXPENT="" F  S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT  D
    119         ..S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
    120         ..I $L(OCXPVAL) D
    121         ...I $P(OCXPENT,";",2)="VA(200,",@(OCXRSLT_OCXOP_OCXPVAL) D
    122         ....I +$$PPLINK^ORQPTQ1(+OCXPENT,OCXPTDFN) D
    123         .....S OCXDUZ(+OCXPENT)="",OCXEXCD=1
    124         Q OCXEXCD                                           
    125         ;
    126 MCE135()        ; Verify Event/Element: DIET ORDER
    127         ;
    128         ;  OCXDF(37) -> PATIENT IEN data field
    129         ;
    130         N OCXRES
    131         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(135,37)=OCXDF(37)
    132         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),135)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),135))
    133         Q 0
    134         ;
    135 MCE136()        ; Verify Event/Element: NO ALLERGY ASSESSMENT
    136         ;
    137         ;  OCXDF(37) -> PATIENT IEN data field
    138         ;
    139         N OCXRES
    140         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(136,37)=OCXDF(37)
    141         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),136)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),136))
    142         Q 0
    143         ;
    144 MCE137()        ; Verify Event/Element: PHARMACY ORDER
    145         ;
    146         ;  OCXDF(37) -> PATIENT IEN data field
    147         ;
    148         N OCXRES
    149         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(137,37)=OCXDF(37)
    150         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),137)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),137))
    151         Q 0
    152         ;
    153 MCE28() ; Verify Event/Element: RADIOLOGY ORDER
    154         ;
    155         ;  OCXDF(37) -> PATIENT IEN data field
    156         ;
    157         N OCXRES
    158         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(28,37)=OCXDF(37)
    159         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),28)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),28))
    160         Q 0
    161         ;
    162 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS)    ; Has this rule already been triggered for this order number
    163         ;
    164         ;
    165         Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
    166         Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
    167         S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
    168         ;
    169         N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
    170         ;
    171         S OCXTIME=(+$H)
    172         S OCXCKSUM=$$CKSUM(OCXMESS)
    173         ;
    174         S OCXTSP=($H*86400)+$P($H,",",2)
    175         S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
    176         ;
    177         Q:(OCXTSPL>OCXTSP) 0
    178         ;
    179         K OCXDATA
    180         S OCXDATA(OCXDFN,0)=OCXDFN
    181         S OCXDATA("B",OCXDFN,OCXDFN)=""
    182         S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
    183         ;
    184         S OCXGR="^OCXD(860.7"
    185         D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
    186         ;
    187         K OCXDATA
    188         S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
    189         S OCXDATA(OCXRUL,"M")=OCXMESS
    190         S OCXDATA("B",OCXRUL,OCXRUL)=""
    191         S OCXGR=OCXGR_","_OCXDFN_",1"
    192         D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
    193         ;
    194         K OCXDATA
    195         S OCXDATA(OCXREL,0)=OCXREL
    196         S OCXDATA("B",OCXREL,OCXREL)=""
    197         S OCXGR=OCXGR_","_OCXRUL_",1"
    198         D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
    199         ;
    200         S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
    201         .;
    202         .N OCXGR1
    203         .S OCXGR1=OCXGR_","_OCXREL_",1"
    204         .K OCXDATA
    205         .S OCXDATA(OCXELE,0)=OCXELE
    206         .S OCXDATA(OCXELE,"TIME")=OCXTIME
    207         .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
    208         .S OCXDATA("B",OCXELE,OCXELE)=""
    209         .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
    210         .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
    211         .;
    212         .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
    213         ..N OCXGR2
    214         ..S OCXGR2=OCXGR1_","_OCXELE_",1"
    215         ..K OCXDATA
    216         ..S OCXDATA(OCXDFI,0)=OCXDFI
    217         ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
    218         ..S OCXDATA("B",OCXDFI,OCXDFI)=""
    219         ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
    220         ;
    221         Q 1
    222         ;
    223 SETAP(ROOT,DD,DATA,DA)  ;  Set Rule Event data
    224         M @ROOT=DATA
    225         I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    226         I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
    227         ;
    228         Q
    229         ;
    230         ;
     1OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R69R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #69 'LAB THRESHOLD'  Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...'
     14 ;  Called from R69R1A+13^OCXOZ11.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ; LABTHRSR( --------> LAB THRESHOLD EXCEEDED RESULTS
     21 ; NEWRULE( ---------> NEW RULE MESSAGE
     22 ;
     23 Q:$D(OCXRULE("R69R1B"))
     24 ;
     25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     26 S OCXCMSG=""
     27 S OCXNMSG="["_$$GETDATA(DFN,"5^131^132",147)_"] Lab threshold exceeded - ["_$$GETDATA(DFN,"5^131^132",96)_"]"
     28 ;
     29 ;
     30 ; Run Execute Code
     31 ;
     32 S OCXTMP=$$LABTHRSR(.OCXDUZ,$$GETDATA(DFN,"5^131^132",113),$$GETDATA(DFN,"5^131^132",152),$$GETDATA(DFN,"5^131^132",12),$$GETDATA(DFN,"5^131^132",37))
     33 Q:$G(OCXOERR)
     34 ;
     35 ; Send Notification
     36 ;
     37 S (OCXDUZ,OCXDATA)="",OCXNUM=0
     38 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D
     39 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3))
     40 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA
     41 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D
     42 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""
     43 .S OCXNUM=+$P(OCXORD,U,2)
     44 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5)
     45 S OCXRULE("R69R1B")=""
     46 I $$NEWRULE(DFN,OCXNUM,69,1,68,OCXNMSG) D  I 1
     47 .D:($G(OCXTRACE)<5) EN^ORB3(68,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)
     48 Q
     49 ;
     50R70R1A ; Verify all Event/Elements of  Rule #70 'NO ALLERGY ASSESSMENT'  Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...'
     51 ;  Called from EL28+5^OCXOZ0I, and EL135+5^OCXOZ0I, and EL136+5^OCXOZ0I, and EL137+5^OCXOZ0I.
     52 ;
     53 Q:$G(OCXOERR)
     54 ;
     55 ;      Local Extrinsic Functions
     56 ; MCE135( ---------->  Verify Event/Element: 'DIET ORDER'
     57 ; MCE136( ---------->  Verify Event/Element: 'NO ALLERGY ASSESSMENT'
     58 ; MCE137( ---------->  Verify Event/Element: 'PHARMACY ORDER'
     59 ; MCE28( ----------->  Verify Event/Element: 'RADIOLOGY ORDER'
     60 ;
     61 Q:$G(^OCXS(860.2,70,"INACT"))
     62 ;
     63 I $$MCE136 D
     64 .I $$MCE28 D R70R1B
     65 .I $$MCE137 D R70R1B
     66 .I $$MCE135 D R70R1B
     67 Q
     68 ;
     69R70R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #70 'NO ALLERGY ASSESSMENT'  Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...'
     70 ;  Called from R70R1A+14.
     71 ;
     72 Q:$G(OCXOERR)
     73 ;
     74 ;      Local Extrinsic Functions
     75 ; NEWRULE( ---------> NEW RULE MESSAGE
     76 ;
     77 Q:$D(OCXRULE("R70R1B"))
     78 ;
     79 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     80 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^32^^Patient has no allergy assessment." I 1
     81 E  S OCXCMSG="Patient has no allergy assessment."
     82 S OCXNMSG=""
     83 ;
     84 ;
     85 ; Run Execute Code
     86 ;
     87 Q:'$$NEWRULE(DFN,$J,39,1,999,"Patient has no allergy assessment.")
     88 Q:$G(OCXOERR)
     89 ;
     90 ; Send Order Check Message
     91 ;
     92 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     93 Q
     94 ;
     95CKSUM(STR) ;  Compiler Function: GENERATE STRING CHECKSUM
     96 ;
     97 N CKSUM,PTR,ASC S CKSUM=0
     98 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     99 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC
     100 Q +CKSUM
     101 ;
     102GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     103 ;
     104 N OCXE,VAL,PC S VAL=""
     105 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     106 Q VAL
     107 ;
     108LABTHRSR(OCXDUZ,OCXLAB,OCXSPEC,OCXRSLT,OCXPTDFN)       ;  Compiler Function: LAB THRESHOLD EXCEEDED RESULTS
     109 ;
     110 Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT) 0
     111 ;
     112 N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXOP,OCXEXCD
     113 S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC
     114 F OCXOP="<",">" D
     115 .D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
     116 .Q:+$G(ORERR)'=0
     117 .Q:+$G(OCXX)=0
     118 .S OCXPENT="" F  S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT  D
     119 ..S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
     120 ..I $L(OCXPVAL) D
     121 ...I $P(OCXPENT,";",2)="VA(200,",@(OCXRSLT_OCXOP_OCXPVAL) D
     122 ....I +$$PPLINK^ORQPTQ1(+OCXPENT,OCXPTDFN) D
     123 .....S OCXDUZ(+OCXPENT)="",OCXEXCD=1
     124 Q OCXEXCD                                           
     125 ;
     126MCE135() ; Verify Event/Element: DIET ORDER
     127 ;
     128 ;  OCXDF(37) -> PATIENT IEN data field
     129 ;
     130 N OCXRES
     131 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(135,37)=OCXDF(37)
     132 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),135)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),135))
     133 Q 0
     134 ;
     135MCE136() ; Verify Event/Element: NO ALLERGY ASSESSMENT
     136 ;
     137 ;  OCXDF(37) -> PATIENT IEN data field
     138 ;
     139 N OCXRES
     140 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(136,37)=OCXDF(37)
     141 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),136)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),136))
     142 Q 0
     143 ;
     144MCE137() ; Verify Event/Element: PHARMACY ORDER
     145 ;
     146 ;  OCXDF(37) -> PATIENT IEN data field
     147 ;
     148 N OCXRES
     149 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(137,37)=OCXDF(37)
     150 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),137)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),137))
     151 Q 0
     152 ;
     153MCE28() ; Verify Event/Element: RADIOLOGY ORDER
     154 ;
     155 ;  OCXDF(37) -> PATIENT IEN data field
     156 ;
     157 N OCXRES
     158 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(28,37)=OCXDF(37)
     159 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),28)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),28))
     160 Q 0
     161 ;
     162NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number
     163 ;
     164 ;
     165 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0
     166 Q:'$G(OCXREL) 0  Q:'$G(OCXNOTF) 0  Q:'$L($G(OCXMESS)) 0
     167 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN
     168 ;
     169 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL
     170 ;
     171 S OCXTIME=(+$H)
     172 S OCXCKSUM=$$CKSUM(OCXMESS)
     173 ;
     174 S OCXTSP=($H*86400)+$P($H,",",2)
     175 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300))
     176 ;
     177 Q:(OCXTSPL>OCXTSP) 0
     178 ;
     179 K OCXDATA
     180 S OCXDATA(OCXDFN,0)=OCXDFN
     181 S OCXDATA("B",OCXDFN,OCXDFN)=""
     182 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP
     183 ;
     184 S OCXGR="^OCXD(860.7"
     185 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN)
     186 ;
     187 K OCXDATA
     188 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD)
     189 S OCXDATA(OCXRUL,"M")=OCXMESS
     190 S OCXDATA("B",OCXRUL,OCXRUL)=""
     191 S OCXGR=OCXGR_","_OCXDFN_",1"
     192 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL)
     193 ;
     194 K OCXDATA
     195 S OCXDATA(OCXREL,0)=OCXREL
     196 S OCXDATA("B",OCXREL,OCXREL)=""
     197 S OCXGR=OCXGR_","_OCXRUL_",1"
     198 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL)
     199 ;
     200 S OCXELE=0 F  S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE  D
     201 .;
     202 .N OCXGR1
     203 .S OCXGR1=OCXGR_","_OCXREL_",1"
     204 .K OCXDATA
     205 .S OCXDATA(OCXELE,0)=OCXELE
     206 .S OCXDATA(OCXELE,"TIME")=OCXTIME
     207 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG)
     208 .S OCXDATA("B",OCXELE,OCXELE)=""
     209 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE)
     210 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE)
     211 .;
     212 .S OCXDFI=0 F  S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI  D
     213 ..N OCXGR2
     214 ..S OCXGR2=OCXGR1_","_OCXELE_",1"
     215 ..K OCXDATA
     216 ..S OCXDATA(OCXDFI,0)=OCXDFI
     217 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)
     218 ..S OCXDATA("B",OCXDFI,OCXDFI)=""
     219 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI)
     220 ;
     221 Q 1
     222 ;
     223SETAP(ROOT,DD,DATA,DA) ;  Set Rule Event data
     224 M @ROOT=DATA
     225 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     226 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA)
     227 ;
     228 Q
     229 ;
     230 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m

    r613 r623  
    1 OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R71R1A  ; Verify all Event/Elements of  Rule #71 'OPIOID MEDICATIONS'  Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS'
    14         ;  Called from EL138+5^OCXOZ0I, and EL139+5^OCXOZ0I.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; MCE138( ---------->  Verify Event/Element: 'DUP OPIOID MEDS'
    20         ; MCE139( ---------->  Verify Event/Element: 'OPIOID MED ORDER'
    21         ;
    22         Q:$G(^OCXS(860.2,71,"INACT"))
    23         ;
    24         I $$MCE139 D
    25         .I $$MCE138 D R71R1B^OCXOZ14
    26         Q
    27         ;
    28 MCE138()        ; Verify Event/Element: DUP OPIOID MEDS
    29         ;
    30         ;  OCXDF(158) -> DUPLICATE OPIOID MEDICATIONS TEXT data field
    31         ;  OCXDF(157) -> DUPLICATE OPIOID MEDICATIONS FLAG data field
    32         ;  OCXDF(37) -> PATIENT IEN data field
    33         ;
    34         N OCXRES
    35         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(138,37)=OCXDF(37)
    36         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),138)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),138))
    37         S OCXRES(138)=0,OCXDF(157)=$P($$OPIOID(OCXDF(37)),"^",1) I $L(OCXDF(157)) S OCXRES(138,157)=OCXDF(157) I (OCXDF(157))
    38         E  Q 0
    39         S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2),OCXRES(138)=11 M ^TMP("OCXCHK",$J,OCXDF(37),138)=OCXRES(138)
    40         Q +OCXRES(138)
    41         ;
    42 MCE139()        ; Verify Event/Element: OPIOID MED ORDER
    43         ;
    44         ;  OCXDF(37) -> PATIENT IEN data field
    45         ;
    46         N OCXRES
    47         S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(139,37)=OCXDF(37)
    48         Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),139)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),139))
    49         Q 0
    50         ;
    51 OPIOID(ORPT)    ;determine if pat is receiving opioid med
    52         ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ...
    53         N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN
    54         S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20
    55         K ^TMP("ORR",$J)
    56         S ORDG=$O(^ORD(100.98,"B","RX",ORDG))
    57         D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0)
    58         N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
    59         S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN
    60         F  S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1  D
    61         .S X=^TMP("ORR",$J,HOR,SEQ)
    62         .S ORNUM=+$P(X,";")
    63         .Q:ORNUM=+$G(ORIFN)  ;quit if dup med order # = current order #
    64         .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG")
    65         .I +$G(ORDI)>0 D
    66         ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2)  ;va drug class
    67         ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D  ;opioid classes
    68         ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM)
    69         ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]"
    70         ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT
    71         ...S ORTN=1
    72         I DUPI>0 D
    73         .S DUPLEN=$P(215/DUPI,".")
    74         .F DUPJ=1:1:DUPI D
    75         ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN)
    76         ..E  S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN)
    77         K ^TMP("ORR",$J)
    78         Q ORTN_U_$G(ORDERS)
    79         ;
     1OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R71R1A ; Verify all Event/Elements of  Rule #71 'OPIOID MEDICATIONS'  Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS'
     14 ;  Called from EL138+5^OCXOZ0I, and EL139+5^OCXOZ0I.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; MCE138( ---------->  Verify Event/Element: 'DUP OPIOID MEDS'
     20 ; MCE139( ---------->  Verify Event/Element: 'OPIOID MED ORDER'
     21 ;
     22 Q:$G(^OCXS(860.2,71,"INACT"))
     23 ;
     24 I $$MCE139 D
     25 .I $$MCE138 D R71R1B^OCXOZ14
     26 Q
     27 ;
     28MCE138() ; Verify Event/Element: DUP OPIOID MEDS
     29 ;
     30 ;  OCXDF(158) -> DUPLICATE OPIOID MEDICATIONS TEXT data field
     31 ;  OCXDF(157) -> DUPLICATE OPIOID MEDICATIONS FLAG data field
     32 ;  OCXDF(37) -> PATIENT IEN data field
     33 ;
     34 N OCXRES
     35 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(138,37)=OCXDF(37)
     36 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),138)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),138))
     37 S OCXRES(138)=0,OCXDF(157)=$P($$OPIOID(OCXDF(37)),"^",1) I $L(OCXDF(157)) S OCXRES(138,157)=OCXDF(157) I (OCXDF(157))
     38 E  Q 0
     39 S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2),OCXRES(138)=11 M ^TMP("OCXCHK",$J,OCXDF(37),138)=OCXRES(138)
     40 Q +OCXRES(138)
     41 ;
     42MCE139() ; Verify Event/Element: OPIOID MED ORDER
     43 ;
     44 ;  OCXDF(37) -> PATIENT IEN data field
     45 ;
     46 N OCXRES
     47 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(139,37)=OCXDF(37)
     48 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),139)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),139))
     49 Q 0
     50 ;
     51OPIOID(ORPT) ;determine if pat is receiving opioid med
     52 ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ...
     53 N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN
     54 S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20
     55 K ^TMP("ORR",$J)
     56 S ORDG=$O(^ORD(100.98,"B","RX",ORDG))
     57 D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0)
     58 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
     59 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN
     60 F  S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1  D
     61 .S X=^TMP("ORR",$J,HOR,SEQ)
     62 .S ORNUM=+$P(X,";")
     63 .Q:ORNUM=+$G(ORIFN)  ;quit if dup med order # = current order #
     64 .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG")
     65 .I +$G(ORDI)>0 D
     66 ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2)  ;va drug class
     67 ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D  ;opioid classes
     68 ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM)
     69 ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]"
     70 ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT
     71 ...S ORTN=1
     72 I DUPI>0 D
     73 .S DUPLEN=$P(215/DUPI,".")
     74 .F DUPJ=1:1:DUPI D
     75 ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN)
     76 ..E  S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN)
     77 K ^TMP("ORR",$J)
     78 Q ORTN_U_$G(ORDERS)
     79 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m

    r613 r623  
    1 OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5         ; ***************************************************************
    6         ; ** Warning: This routine is automatically generated by the   **
    7         ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
    8         ; ** will be lost the next time the rule compiler executes.    **
    9         ; ***************************************************************
    10         ;
    11         Q
    12         ;
    13 R71R1B  ; Send Order Check, Notication messages and/or Execute code for  Rule #71 'OPIOID MEDICATIONS'  Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS'
    14         ;  Called from R71R1A+12^OCXOZ13.
    15         ;
    16         Q:$G(OCXOERR)
    17         ;
    18         ;      Local Extrinsic Functions
    19         ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
    20         ;
    21         Q:$D(OCXRULE("R71R1B"))
    22         ;
    23         N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
    24         I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^33^^Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) I 1
    25         E  S OCXCMSG="Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158)
    26         S OCXNMSG=""
    27         ;
    28         Q:$G(OCXOERR)
    29         ;
    30         ; Send Order Check Message
    31         ;
    32         S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
    33         Q
    34         ;
    35 GETDATA(DFN,OCXL,OCXDFI)        ;     This Local Extrinsic Function returns runtime data
    36         ;
    37         N OCXE,VAL,PC S VAL=""
    38         F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
    39         Q VAL
    40         ;
     1OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5 ; ***************************************************************
     6 ; ** Warning: This routine is automatically generated by the   **
     7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine  **
     8 ; ** will be lost the next time the rule compiler executes.    **
     9 ; ***************************************************************
     10 ;
     11 Q
     12 ;
     13R71R1B ; Send Order Check, Notication messages and/or Execute code for  Rule #71 'OPIOID MEDICATIONS'  Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS'
     14 ;  Called from R71R1A+12^OCXOZ13.
     15 ;
     16 Q:$G(OCXOERR)
     17 ;
     18 ;      Local Extrinsic Functions
     19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
     20 ;
     21 Q:$D(OCXRULE("R71R1B"))
     22 ;
     23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
     24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^33^^Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) I 1
     25 E  S OCXCMSG="Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158)
     26 S OCXNMSG=""
     27 ;
     28 Q:$G(OCXOERR)
     29 ;
     30 ; Send Order Check Message
     31 ;
     32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
     33 Q
     34 ;
     35GETDATA(DFN,OCXL,OCXDFI) ;     This Local Extrinsic Function returns runtime data
     36 ;
     37 N OCXE,VAL,PC S VAL=""
     38 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
     39 Q VAL
     40 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND.m

    r613 r623  
    1 OCXSEND ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES ;2/22/08  12:30
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 S       ;
    6         N X,IOP,TOTL S TOTL=0
    7         N CVER,RCNT,RSIZE,LASTFILE,HEADER1,HEADER2,HEADER3,HEADER4,HEADER5
    8         N OCXASK,OCXID,OCXLIN2,OCXLIN3,OCXPATCH,OCXSCR,PARM,PARMV,DIE,DIERR,DIQ2,FCPARM,TEXT
    9         I '$D(IOM) S IOP=0 D ^%ZIS K IOP
    10         K ^TMP("OCXSEND",$J),^UTILITY($J),OCXPATH
    11         K ^UTILITY($J),OCXPATH
    12         S ^TMP("OCXSEND",$J)=($P($H,",",2)+($H*86400)+(4*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    13         S OCXLIN2=$T(+2)
    14         S OCXLIN3=$T(+3)
    15         ;
    16         D ^OCXSEND1 ; Get List of Objects to Transport
    17         ;
    18         I '$O(^TMP("OCXSEND",$J,"LIST",0)) K ^TMP("OCXSEND",$J) Q  ; Nothing selected so Quit
    19         ;
    20         S OCXASK="" F  D  Q:$L(OCXASK)
    21         .W !
    22         .W !,"When the transport routine encounters locally"
    23         .W !,"altered rule data at a site, do you want to:"
    24         .;
    25         .S OCXASK=$$READ("S^O:Overwrite local data;D:Display locally altered data only;A:Ask the site what to do","(O)verwrite, (D)isplay, or (A)sk the site ? ","Ask")
    26         ;
    27         Q:(OCXASK[U)
    28         I (OCXASK="O") W !!,"Locally altered data will be overwritten without asking.",!!
    29         I (OCXASK="D") W !!,"Locally altered data will be displayed only.",!!
    30         I (OCXASK="A") W !!,"Sites will be asked before locally altered data is overwritten.",!!
    31         ;
    32         S OCXPATCH="" F  D  Q:$L(OCXPATCH)
    33         .W !!,"Enter Patch ID (ex. OR*3*96): " R OCXPATCH:DTIME E  S OCXPATCH="^" Q
    34         .Q:(OCXPATCH="^")
    35         .I '$L(OCXPATCH) S OCXPATCH="^^" Q
    36         .I $L(OCXPATCH),'(OCXPATCH?1"OR*"1N1"*"1.4N) D  S OCXPATCH="" Q
    37         ..W !!
    38         ..W:'(OCXPATCH["?") "Invalid"
    39         ..W " Format -> OR*v*ppp"
    40         ..W !,"   v = Package Version."
    41         ..W !," ppp = Patch Number."
    42         ..W !
    43         Q:(OCXPATCH="^")
    44         S:(OCXPATCH="^^") OCXPATCH=""
    45         I $P(OCXPATCH,"*",3) S $P(OCXLIN2,";",5)="**"_$P(OCXPATCH,"*",3)_"**"
    46         I $L(OCXPATCH) S OCXPATCH="(Delete after Install of "_OCXPATCH_")"
    47         ;
    48         Q:'$$RSDEL
    49         ;
    50         D ^OCXSEND2 ; Get File Data
    51         ;
    52         S TOTL=$$EN^OCXSEND3 ; File Routines
    53         ;
    54         S TOTL=TOTL+$$EN^OCXSENDA ; File Main Runtime Library Routine
    55         ;
    56         S TOTL=TOTL+$$EN^OCXSEND4 ; File Utility Runtime Library Routine 0
    57         ;
    58         S TOTL=TOTL+$$EN^OCXSEND5 ; File Utility Runtime Library Routine 1
    59         ;
    60         S TOTL=TOTL+$$EN^OCXSEND6 ; File Utility Runtime Library Routine 2
    61         ;
    62         S TOTL=TOTL+$$EN^OCXSEND7 ; File Utility Runtime Library Routine 3
    63         ;
    64         S TOTL=TOTL+$$EN^OCXSEND8 ; File Utility Runtime Library Routine 4
    65         ;
    66 EXIT    K ^TMP("OCXSEND",$J),^UTILITY($J)
    67         ;
    68         W !!,"Routines filed.",!!
    69         ;
    70         Q
    71         ;
    72 READ(OCX0,OCXA,OCXB,OCXL)       ;
    73         N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    74         Q:'$L($G(OCX0)) U
    75         S DIR(0)=OCX0
    76         S:$L($G(OCXA)) DIR("A")=OCXA
    77         S:$L($G(OCXB)) DIR("B")=OCXB
    78         F X=1:1:($G(OCXL)-1) W !
    79         D ^DIR
    80         I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    81         Q Y
    82         ;
    83 CUCI()  Q:'$D(^%ZOSF("UCI")) "" N Y X ^%ZOSF("UCI") Q Y
    84         ;
    85 NETNAME()       ;
    86         N NETNAME
    87         S NETNAME=$P($$NETNAME^XMXUTIL(DUZ),"@",2)
    88         I $L(NETNAME) Q NETNAME
    89         ; Q:$L($G(^XMB("NETNAME"))) ^XMB("NETNAME")
    90         ; Q:$L($G(^XMB("NAME"))) ^XMB("NAME")
    91         Q $$CUCI
    92         ;
    93 RSDEL() ;
    94         ;
    95         W !!,"Scanning for old rule transport routines..."
    96         N X,CNT,RCNT,RLIST,RNAME
    97         S RCNT=0
    98         ;
    99         ;  Scan for Routines To Delete
    100         ;
    101         ; Main Routine
    102         S RNAME=$$RNAME^OCXSEND3(0,0) I $$RFIND(RNAME,100) S RLIST(RNAME)=""
    103         ;
    104         ; Runtime Library routines
    105         F CNT=0:1:35 S RNAME=$$RNAME^OCXSEND3(CNT,1) I $$RFIND(RNAME,CNT) S RLIST(RNAME)=""
    106         ;
    107         ; Data Routines
    108         F CNT=0:1:46655 S RNAME=$$RNAME^OCXSEND3(CNT,2) I $$RFIND(RNAME,CNT) S RLIST(RNAME)=""
    109         ;
    110         I '$L($O(RLIST(""))) W !,"No old rule transport routines found..." H 2 Q 1
    111         ;
    112         W !!,"These routines will be deleted and overwritten."
    113         Q:'$$READ("Y"," Do you want to proceed?","NO") 0
    114         ;
    115         ;    Delete The routines
    116         ;
    117         I '$D(^%ZOSF("DEL")) W !!,"Old rule transport routines not deleted (^%ZOSF(""DEL"") undefined)" Q 0
    118         ;
    119         S RNAME="" F RCNT=1:1 S RNAME=$O(RLIST(RNAME)) Q:'$L(RNAME)  D
    120         .W !,RNAME
    121         .I $$RDEL(RNAME) W "   Deleted..." Q
    122         .W "   Not Deleted..."
    123         ;
    124         W !!,RCNT," routine",$S((RCNT=1):"",1:"s")," deleted."
    125         ;
    126         H 2 Q 1
    127         ;
    128 RFIND(X,C)      ;
    129         W:($X>70) ! W:'(C#100) "."
    130         Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0
    131         W !,X Q 1
    132         Q
    133         ;
    134 RDEL(X) ;
    135         ;
    136         Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0
    137         X ^%ZOSF("DEL") Q 1
    138         ;
     1OCXSEND ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES ;2/01/01  10:10
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5S ;
     6 N X,IOP,TOTL S TOTL=0
     7 N CVER,RCNT,RSIZE,LASTFILE,HEADER1,HEADER2,HEADER3,HEADER4,HEADER5
     8 N OCXASK,OCXID,OCXLIN2,OCXLIN3,OCXPATCH,OCXSCR,PARM,PARMV,DIE,DIERR,DIQ2,FCPARM,TEXT
     9 I '$D(IOM) S IOP=0 D ^%ZIS K IOP
     10 K ^TMP("OCXSEND",$J),^UTILITY($J),OCXPATH
     11 K ^UTILITY($J),OCXPATH
     12 S ^TMP("OCXSEND",$J)=($P($H,",",2)+($H*86400)+(4*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     13 S OCXLIN2=$T(+2)
     14 S OCXLIN3=$T(+3)
     15 ;
     16 D ^OCXSEND1 ; Get List of Objects to Transport
     17 ;
     18 I '$O(^TMP("OCXSEND",$J,"LIST",0)) K ^TMP("OCXSEND",$J) Q  ; Nothing selected so Quit
     19 ;
     20 S OCXASK="" F  D  Q:$L(OCXASK)
     21 .W !
     22 .W !,"When the transport routine encounters locally"
     23 .W !,"altered rule data at a site, do you want to:"
     24 .;
     25 .S OCXASK=$$READ("S^O:Overwrite local data;D:Display locally altered data only;A:Ask the site what to do","(O)verwrite, (D)isplay, or (A)sk the site ? ","Ask")
     26 ;
     27 Q:(OCXASK[U)
     28 I (OCXASK="O") W !!,"Locally altered data will be overwritten without asking.",!!
     29 I (OCXASK="D") W !!,"Locally altered data will be displayed only.",!!
     30 I (OCXASK="A") W !!,"Sites will be asked before locally altered data is overwritten.",!!
     31 ;
     32 S OCXPATCH="" F  D  Q:$L(OCXPATCH)
     33 .W !!,"Enter Patch ID (ex. OR*3*96): " R OCXPATCH:DTIME E  S OCXPATCH="^" Q
     34 .Q:(OCXPATCH="^")
     35 .I '$L(OCXPATCH) S OCXPATCH="^^" Q
     36 .I $L(OCXPATCH),'(OCXPATCH?1"OR*"1N1"*"1.4N) D  S OCXPATCH="" Q
     37 ..W !!
     38 ..W:'(OCXPATCH["?") "Invalid"
     39 ..W " Format -> OR*v*ppp"
     40 ..W !,"   v = Package Version."
     41 ..W !," ppp = Patch Number."
     42 ..W !
     43 Q:(OCXPATCH="^")
     44 S:(OCXPATCH="^^") OCXPATCH=""
     45 I $P(OCXPATCH,"*",3) S $P(OCXLIN2,";",5)="**"_$P(OCXPATCH,"*",3)_"**"
     46 I $L(OCXPATCH) S OCXPATCH="(Delete after Install of "_OCXPATCH_")"
     47 ;
     48 Q:'$$RSDEL
     49 ;
     50 D ^OCXSEND2 ; Get File Data
     51 ;
     52 S TOTL=$$EN^OCXSEND3 ; File Routines
     53 ;
     54 S TOTL=TOTL+$$EN^OCXSENDA ; File Main Runtime Library Routine
     55 ;
     56 S TOTL=TOTL+$$EN^OCXSEND4 ; File Utility Runtime Library Routine 0
     57 ;
     58 S TOTL=TOTL+$$EN^OCXSEND5 ; File Utility Runtime Library Routine 1
     59 ;
     60 S TOTL=TOTL+$$EN^OCXSEND6 ; File Utility Runtime Library Routine 2
     61 ;
     62 S TOTL=TOTL+$$EN^OCXSEND7 ; File Utility Runtime Library Routine 3
     63 ;
     64 S TOTL=TOTL+$$EN^OCXSEND8 ; File Utility Runtime Library Routine 4
     65 ;
     66EXIT K ^TMP("OCXSEND",$J),^UTILITY($J)
     67 ;
     68 W !!,TOTL,"  total lines of code filed.",!!
     69 ;
     70 Q
     71 ;
     72READ(OCX0,OCXA,OCXB,OCXL) ;
     73 N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     74 Q:'$L($G(OCX0)) U
     75 S DIR(0)=OCX0
     76 S:$L($G(OCXA)) DIR("A")=OCXA
     77 S:$L($G(OCXB)) DIR("B")=OCXB
     78 F X=1:1:($G(OCXL)-1) W !
     79 D ^DIR
     80 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     81 Q Y
     82 ;
     83CUCI() Q:'$D(^%ZOSF("UCI")) "" N Y X ^%ZOSF("UCI") Q Y
     84 ;
     85NETNAME() ;
     86 Q:$L($G(^XMB("NETNAME"))) ^XMB("NETNAME")
     87 Q:$L($G(^XMB("NAME"))) ^XMB("NAME")
     88 Q $$CUCI
     89 ;
     90RSDEL() ;
     91 ;
     92 W !!,"Scanning for old rule transport routines..."
     93 N X,CNT,RCNT,RLIST,RNAME
     94 S RCNT=0
     95 ;
     96 ;  Scan for Routines To Delete
     97 ;
     98 ; Main Routine
     99 S RNAME=$$RNAME^OCXSEND3(0,0) I $$RFIND(RNAME,100) S RLIST(RNAME)=""
     100 ;
     101 ; Runtime Library routines
     102 F CNT=0:1:35 S RNAME=$$RNAME^OCXSEND3(CNT,1) I $$RFIND(RNAME,CNT) S RLIST(RNAME)=""
     103 ;
     104 ; Data Routines
     105 F CNT=0:1:46655 S RNAME=$$RNAME^OCXSEND3(CNT,2) I $$RFIND(RNAME,CNT) S RLIST(RNAME)=""
     106 ;
     107 I '$L($O(RLIST(""))) W !,"No old rule transport routines found..." H 2 Q 1
     108 ;
     109 W !!,"These routines will be deleted and overwritten."
     110 Q:'$$READ("Y"," Do you want to proceed?","NO") 0
     111 ;
     112 ;    Delete The routines
     113 ;
     114 I '$D(^%ZOSF("DEL")) W !!,"Old rule transport routines not deleted (^%ZOSF(""DEL"") undefined)" Q 0
     115 ;
     116 S RNAME="" F RCNT=1:1 S RNAME=$O(RLIST(RNAME)) Q:'$L(RNAME)  D
     117 .W !,RNAME
     118 .I $$RDEL(RNAME) W "   Deleted..." Q
     119 .W "   Not Deleted..."
     120 ;
     121 W !!,RCNT," routine",$S((RCNT=1):"",1:"s")," deleted."
     122 ;
     123 H 2 Q 1
     124 ;
     125RFIND(X,C) ;
     126 W:($X>70) ! W:'(C#100) "."
     127 Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0
     128 W !,X Q 1
     129 Q
     130 ;
     131RDEL(X) ;
     132 ;
     133 Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0
     134 X ^%ZOSF("DEL") Q 1
     135 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND3.m

    r613 r623  
    1 OCXSEND3        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Routines) ;1/31/01  08:51
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N LAST,RLINE,RNUM,RTEXT,TOTLINE
    8         K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;"
    9         S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F  S RLINE=$O(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'RLINE  D
    10         .S RTEXT=$G(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'$L(RTEXT)
    11         .S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT)
    12         .S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;;"_RTEXT
    13         .I (RSIZE>6000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXSEND",$J,"DATA",RLINE)),.RNUM) S (RSIZE,RCNT)=0
    14         I $O(^TMP("OCXSEND",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM)
    15         ;
    16         Q TOTLINE
    17         ;
    18 RFILE(LINK,RNUM)        ;
    19         ;
    20         N DIE,LAST,X,XCN
    21         D HDR(LINK,RNUM)
    22         S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1
    23         S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;1;"
    24         S ^TMP("OCXSEND",$J,"RTN",LAST+1,0)=" ;"
    25         S ^TMP("OCXSEND",$J,"RTN",LAST+2,0)="$"
    26         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0
    27         S X=$$RNAME(RNUM,2)
    28         W !,X
    29         X ^%ZOSF("SAVE")
    30         S RNUM=RNUM+1
    31         K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;"
    32         Q ""
    33         ;
    34 NOW()   ;
    35         N X,Y,%DT
    36         S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y)
    37         I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2)
    38         Q Y
    39         ;
    40 HDR(LINK,RNUM)  ;
    41         ;
    42         N R,LINE,TEXT,RNAME,RLINK,NOW
    43         S NOW=$$NOW
    44         I 'LINK S RLINK=";"
    45         E  S RLINK="G ^"_$$RNAME(RNUM+1,2)
    46         S RNAME=$$RNAME(RNUM,2),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";"
    47         ;
    48         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT)
    49         ;
    50         M ^TMP("OCXSEND",$J,"RTN")=R
    51         ;
    52         Q
    53         ;
    54 HEX(X)  Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1))
    55         ;
    56 RNAME(X,Y)      ;
    57         ; Y=0  -> Main Routine
    58         ; Y=1  -> Runtime Library Routine
    59         ; Y=2  -> Data Routine for ORYppp
    60         ; Y=3  -> Data Routine for OCXRU
    61         ;
    62         N OCXRN1,OCXRN2,OCXSEQ
    63         ;
    64         S OCXRN1="OCXRULE",OCXRN2="OCXRU"
    65         S:$L($G(OCXPATCH)) OCXRN2="ORY"_$E((1000+$P(OCXPATCH,"*",3)),2,4),OCXRN1=OCXRN2_"ES"
    66         ;
    67         Q:'Y OCXRN1
    68         ;
    69         I (Y=1),(X>35) Q ""
    70         I (Y=2),'$L($G(OCXPATCH)) S Y=3
    71         I (Y=2),(X>1295) Q ""
    72         I (Y=3),(X>46655) Q ""
    73         ;
    74         S OCXSEQ=0 S:X OCXSEQ=$$HEX(X)
    75         S OCXSEQ="00000"_OCXSEQ
    76         S OCXSEQ=$E(OCXSEQ,($L(OCXSEQ)-Y+1),$L(OCXSEQ))
    77         ;
    78         Q OCXRN2_OCXSEQ
    79         ;
    80 CONV(X) ;
    81         N VAL
    82         F  Q:'(X["|")  D
    83         .S VAL=$P(X,"|",2)
    84         .X "S VAL="_VAL
    85         .S X=$P(X,"|",1)_VAL_$P(X,"|",3,999)
    86         I '(X="$"),'$L($P(X," ",2)) S X=X_" ;"
    87         Q X
    88         ;
    89 TEXT    ;
    90         ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    91         ;;|OCXLIN2|
    92         ;;|OCXLIN3|
    93         ;; ;
    94         ;;S ;
    95         ;; ;
    96         ;; D DOT^|$$RNAME^OCXSEND3(0,0)|
    97         ;; ;
    98         ;; ;
    99         ;; K REMOTE,LOCAL,OPCODE,REF
    100         ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT  I $L(TEXT) D  Q:QUIT
    101         ;; .S ^TMP("OCXRULE",$J,$O(^TMP("OCXRULE",$J,"A"),-1)+1)=TEXT
    102         ;; ;
    103         ;; |RLINK|
    104         ;; ;
    105         ;; Q
    106         ;; ;
    107         ;;DATA ;
    108         ;1;
    109         ;
     1OCXSEND3 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Routines) ;1/31/01  08:51
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N LAST,RLINE,RNUM,RTEXT,TOTLINE
     8 K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;"
     9 S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F  S RLINE=$O(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'RLINE  D
     10 .S RTEXT=$G(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'$L(RTEXT)
     11 .S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT)
     12 .S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;;"_RTEXT
     13 .I (RSIZE>6000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXSEND",$J,"DATA",RLINE)),.RNUM) S (RSIZE,RCNT)=0
     14 I $O(^TMP("OCXSEND",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM)
     15 ;
     16 Q TOTLINE
     17 ;
     18RFILE(LINK,RNUM) ;
     19 ;
     20 N DIE,LAST,X,XCN,XCM
     21 D HDR(LINK,RNUM)
     22 S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1
     23 S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;1;"
     24 S ^TMP("OCXSEND",$J,"RTN",LAST+1,0)=" ;"
     25 S ^TMP("OCXSEND",$J,"RTN",LAST+2,0)="$"
     26 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0
     27 S X=$$RNAME(RNUM,2)
     28 W !,X
     29 X ^%ZOSF("SAVE")
     30 W "  ... ",XCM," Lines filed"
     31 S RNUM=RNUM+1
     32 K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;"
     33 Q XCM
     34 ;
     35NOW() ;
     36 N X,Y,%DT
     37 S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y)
     38 I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2)
     39 Q Y
     40 ;
     41HDR(LINK,RNUM) ;
     42 ;
     43 N R,LINE,TEXT,RNAME,RLINK,NOW
     44 S NOW=$$NOW
     45 I 'LINK S RLINK=";"
     46 E  S RLINK="G ^"_$$RNAME(RNUM+1,2)
     47 S RNAME=$$RNAME(RNUM,2),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";"
     48 ;
     49 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT)
     50 ;
     51 M ^TMP("OCXSEND",$J,"RTN")=R
     52 ;
     53 Q
     54 ;
     55HEX(X) Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1))
     56 ;
     57RNAME(X,Y) ;
     58 ; Y=0  -> Main Routine
     59 ; Y=1  -> Runtime Library Routine
     60 ; Y=2  -> Data Routine for ORYppp
     61 ; Y=3  -> Data Routine for OCXRU
     62 ;
     63 N OCXRN1,OCXRN2,OCXSEQ
     64 ;
     65 S OCXRN1="OCXRULE",OCXRN2="OCXRU"
     66 S:$L($G(OCXPATCH)) OCXRN2="ORY"_$E((1000+$P(OCXPATCH,"*",3)),2,4),OCXRN1=OCXRN2_"ES"
     67 ;
     68 Q:'Y OCXRN1
     69 ;
     70 I (Y=1),(X>35) Q ""
     71 I (Y=2),'$L($G(OCXPATCH)) S Y=3
     72 I (Y=2),(X>1295) Q ""
     73 I (Y=3),(X>46655) Q ""
     74 ;
     75 S OCXSEQ=0 S:X OCXSEQ=$$HEX(X)
     76 S OCXSEQ="00000"_OCXSEQ
     77 S OCXSEQ=$E(OCXSEQ,($L(OCXSEQ)-Y+1),$L(OCXSEQ))
     78 ;
     79 Q OCXRN2_OCXSEQ
     80 ;
     81CONV(X) ;
     82 N VAL
     83 F  Q:'(X["|")  D
     84 .S VAL=$P(X,"|",2)
     85 .X "S VAL="_VAL
     86 .S X=$P(X,"|",1)_VAL_$P(X,"|",3,999)
     87 I '(X="$"),'$L($P(X," ",2)) S X=X_" ;"
     88 Q X
     89 ;
     90TEXT ;
     91 ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     92 ;;|OCXLIN2|
     93 ;;|OCXLIN3|
     94 ;; ;
     95 ;;S ;
     96 ;; ;
     97 ;; D DOT^|$$RNAME^OCXSEND3(0,0)|
     98 ;; ;
     99 ;; ;
     100 ;; K REMOTE,LOCAL,OPCODE,REF
     101 ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT  I $L(TEXT) D  Q:QUIT
     102 ;; .S ^TMP("OCXRULE",$J,$O(^TMP("OCXRULE",$J,"A"),-1)+1)=TEXT
     103 ;; ;
     104 ;; |RLINK|
     105 ;; ;
     106 ;; Q
     107 ;; ;
     108 ;;DATA ;
     109 ;1;
     110 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND4.m

    r613 r623  
    1 OCXSEND4        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 0) ;2/01/01  09:56
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N R,LINE,TEXT,NOW,RUCI
    8         S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
    9         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
    10         ;
    11         M ^TMP("OCXSEND",$J,"RTN")=R
    12         ;
    13         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,1)
    14         W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN")
    15         ;
    16         Q " "
    17         ;
    18 TEXT    ;
    19         ;;|$$RNAME^OCXSEND3(0,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    20         ;;|OCXLIN2|
    21         ;;|OCXLIN3|
    22         ;; ;
    23         ;;S ;
    24         ;; ;
    25         ;; Q
    26         ;; ;
    27         ;;WARN(RTN,MSG,LINES) ;
    28         ;; ;
    29         ;; Q:$G(OCXAUTO)
    30         ;; ;
    31         ;; N DASH,LINE,NLINE,PLINE
    32         ;; ;
    33         ;; S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-"
    34         ;; W !!,"--------------",MSG,DASH
    35         ;; ;
    36         ;; W !,RTN,?10,"[|RUCI|] -> [",$$NETNAME^OCXSEND,"] Line"
    37         ;; ;
    38         ;; I $O(LINES($O(LINES(0)))) W "s: "
    39         ;; E  W ": "
    40         ;; ;
    41         ;; S LINE=0 F  S LINE=$O(LINES(LINE)) Q:'LINE  D
    42         ;; .W:($X>60) !,?40
    43         ;; .S NLINE=LINE F  S PLINE=NLINE,NLINE=$O(LINES(NLINE)) Q:(NLINE-PLINE-1)
    44         ;; .I (PLINE=LINE) W " ",LINE
    45         ;; .E  W " ",LINE,"-",PLINE S LINE=PLINE
    46         ;; ;
    47         ;; W ! Q
    48         ;; ;
    49         ;;TEXT(RTN,LINE) ;
    50         ;; ;
    51         ;; N TEXT X "S TEXT=$T(+"_(+LINE)_"^"_RTN_")" Q TEXT
    52         ;; ;
    53         ;;HEADER ;
    54         ;; ;
    55         ;; W !," Created: |NOW|  at  |RUCI|"
    56         ;; W !," Current Date: ",$$NOW,"  at  ",$$NETNAME^OCXSEND,!!
    57         ;; S LASTFILE=0 K ^TMP("OCXRULE",$J)
    58         ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    59         ;; Q
    60         ;; ;
    61         ;;GETFILE(FILE,RECNAME,ARRAY) ;
    62         ;; ;
    63         ;; N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD
    64         ;; S REC=$$LOOKUP(FILE,RECNAME)
    65         ;; I 'REC W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME Q 0
    66         ;; I (REC=-1) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME,"  duplicate local entries.",! Q 0
    67         ;; I (REC=-2) W !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC
    68         ;; I (REC<0) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME,"  unknown lookup error." W ! Q:$$PAUSE -10 Q REC
    69         ;; I (REC>0) D
    70         ;; .S CHECK=0,LINES=0
    71         ;; .D GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY)
    72         ;; .S GLREF="ARRAY" F  S GLREF=$Q(@GLREF) Q:'$L(GLREF)  Q:'($E(GLREF,1,6)="ARRAY(")  K:'$L(@GLREF) @GLREF
    73         ;; ;
    74         ;; Q REC
    75         ;; ;
    76         ;;LKUPARRY(DD,KEY,ARRAY) ;
    77         ;; ;
    78         ;; N D0 S D0=0 F  S D0=$O(ARRAY(DD,D0)) Q:'D0  Q:($G(ARRAY(DD,D0,.01,"E"))=KEY)
    79         ;; Q D0
    80         ;; ;
    81         ;;LOOKUP(FILE,KEY) ;
    82         ;; I $O(^TMP("OCXRULE",$J,"B",FILE,KEY,0)) Q 0
    83         ;; N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0
    84         ;; S GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME") Q:'$L(GL) -2 S GL=$E(GL,1,$L(GL)-1)_")"
    85         ;; S SHORT=$E(KEY,1,30),RECNAM=SHORT D  F  S RECNAM=$O(@GL@("B",RECNAM)) Q:'$L(RECNAM)  Q:'($E(RECNAM,1,$L(SHORT))=SHORT)  D
    86         ;; .S D0=0 F  S D0=$O(@GL@("B",RECNAM,D0)) Q:'D0  I ($P($G(@GL@(D0,0)),U,1)=KEY) S CNT=CNT+1,REC=D0_U_RECNAME
    87         ;; Q:(CNT>1) -1
    88         ;; S:$L($P(REC,U,2)) ^TMP("OCXRULE",$J,"A",FILE,$P(REC,U,2))=""
    89         ;; Q +REC
    90         ;; ;
    91         ;;GETREC(GL,PATH,D0,REM) ;
    92         ;; ;
    93         ;; Q:'($P($G(@(GL_"0)")),U,2))
    94         ;; N S1,DATA,DD
    95         ;; S DATA="" D DIQ(GL,D0,.DATA)
    96         ;; S DD=$O(DATA(0)) Q:'DD
    97         ;; ;
    98         ;; I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_""""
    99         ;; I '$L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_","""_DD_":"_D0_""""
    100         ;; M @(PATH_")")=DATA(DD,D0)
    101         ;; ;
    102         ;; S S1="" F  S S1=$O(@(GL_D0_","_$$SUB(S1)_")")) Q:'$L(S1)  I ($D(@(GL_D0_","_$$SUB(S1)_")"))>3) D
    103         ;; .N D1,GLREF S GLREF=GL_D0_","_$$SUB(S1)_","
    104         ;; .S D1=0 F  S D1=$O(@(GLREF_D1_")")) Q:'D1  D GETREC(GLREF,PATH,D1,.REM)
    105         ;; ;
    106         ;; Q
    107         ;; ;
    108         ;;SUB(X) Q:'(X=+X) """"_X_"""" Q X
    109         ;; ;
    110         ;;DIQ(DIC,DA,OCXARY) ;
    111         ;; N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="EN" D EN^DIQ1
    112         ;; Q
    113         ;; ;
    114         ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
    115         ;; ;
    116         ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
    117         ;; ;
    118         ;;$
    119         ;1;
    120         ;
     1OCXSEND4 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 0) ;2/01/01  09:56
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N R,LINE,TEXT,NOW,RUCI,XCM
     8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
     9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
     10 ;
     11 M ^TMP("OCXSEND",$J,"RTN")=R
     12 ;
     13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,1)
     14 W !,X X ^%ZOSF("SAVE") W "  ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN")
     15 ;
     16 Q XCM
     17 ;
     18TEXT ;
     19 ;;|$$RNAME^OCXSEND3(0,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     20 ;;|OCXLIN2|
     21 ;;|OCXLIN3|
     22 ;; ;
     23 ;;S ;
     24 ;; ;
     25 ;; Q
     26 ;; ;
     27 ;;WARN(RTN,MSG,LINES) ;
     28 ;; ;
     29 ;; Q:$G(OCXAUTO)
     30 ;; ;
     31 ;; N DASH,LINE,NLINE,PLINE
     32 ;; ;
     33 ;; S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-"
     34 ;; W !!,"--------------",MSG,DASH
     35 ;; ;
     36 ;; W !,RTN,?10,"[|RUCI|] -> [",$$NETNAME^OCXSEND,"] Line"
     37 ;; ;
     38 ;; I $O(LINES($O(LINES(0)))) W "s: "
     39 ;; E  W ": "
     40 ;; ;
     41 ;; S LINE=0 F  S LINE=$O(LINES(LINE)) Q:'LINE  D
     42 ;; .W:($X>60) !,?40
     43 ;; .S NLINE=LINE F  S PLINE=NLINE,NLINE=$O(LINES(NLINE)) Q:(NLINE-PLINE-1)
     44 ;; .I (PLINE=LINE) W " ",LINE
     45 ;; .E  W " ",LINE,"-",PLINE S LINE=PLINE
     46 ;; ;
     47 ;; W ! Q
     48 ;; ;
     49 ;;TEXT(RTN,LINE) ;
     50 ;; ;
     51 ;; N TEXT X "S TEXT=$T(+"_(+LINE)_"^"_RTN_")" Q TEXT
     52 ;; ;
     53 ;;HEADER ;
     54 ;; ;
     55 ;; W !," Created: |NOW|  at  |RUCI|"
     56 ;; W !," Current Date: ",$$NOW,"  at  ",$$NETNAME^OCXSEND,!!
     57 ;; S LASTFILE=0 K ^TMP("OCXRULE",$J)
     58 ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     59 ;; Q
     60 ;; ;
     61 ;;GETFILE(FILE,RECNAME,ARRAY) ;
     62 ;; ;
     63 ;; N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD
     64 ;; S REC=$$LOOKUP(FILE,RECNAME)
     65 ;; I 'REC W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME Q 0
     66 ;; I (REC=-1) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME,"  duplicate local entries.",! Q 0
     67 ;; I (REC=-2) W !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC
     68 ;; I (REC<0) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME,"  unknown lookup error." W ! Q:$$PAUSE -10 Q REC
     69 ;; I (REC>0) D
     70 ;; .S CHECK=0,LINES=0
     71 ;; .D GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY)
     72 ;; .S GLREF="ARRAY" F  S GLREF=$Q(@GLREF) Q:'$L(GLREF)  Q:'($E(GLREF,1,6)="ARRAY(")  K:'$L(@GLREF) @GLREF
     73 ;; ;
     74 ;; Q REC
     75 ;; ;
     76 ;;LKUPARRY(DD,KEY,ARRAY) ;
     77 ;; ;
     78 ;; N D0 S D0=0 F  S D0=$O(ARRAY(DD,D0)) Q:'D0  Q:($G(ARRAY(DD,D0,.01,"E"))=KEY)
     79 ;; Q D0
     80 ;; ;
     81 ;;LOOKUP(FILE,KEY) ;
     82 ;; I $O(^TMP("OCXRULE",$J,"B",FILE,KEY,0)) Q 0
     83 ;; N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0
     84 ;; S GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME") Q:'$L(GL) -2 S GL=$E(GL,1,$L(GL)-1)_")"
     85 ;; S SHORT=$E(KEY,1,30),RECNAM=SHORT D  F  S RECNAM=$O(@GL@("B",RECNAM)) Q:'$L(RECNAM)  Q:'($E(RECNAM,1,$L(SHORT))=SHORT)  D
     86 ;; .S D0=0 F  S D0=$O(@GL@("B",RECNAM,D0)) Q:'D0  I ($P($G(@GL@(D0,0)),U,1)=KEY) S CNT=CNT+1,REC=D0_U_RECNAME
     87 ;; Q:(CNT>1) -1
     88 ;; S:$L($P(REC,U,2)) ^TMP("OCXRULE",$J,"A",FILE,$P(REC,U,2))=""
     89 ;; Q +REC
     90 ;; ;
     91 ;;GETREC(GL,PATH,D0,REM) ;
     92 ;; ;
     93 ;; Q:'($P($G(@(GL_"0)")),U,2))
     94 ;; N S1,DATA,DD
     95 ;; S DATA="" D DIQ(GL,D0,.DATA)
     96 ;; S DD=$O(DATA(0)) Q:'DD
     97 ;; ;
     98 ;; I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_""""
     99 ;; I '$L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_","""_DD_":"_D0_""""
     100 ;; M @(PATH_")")=DATA(DD,D0)
     101 ;; ;
     102 ;; S S1="" F  S S1=$O(@(GL_D0_","_$$SUB(S1)_")")) Q:'$L(S1)  I ($D(@(GL_D0_","_$$SUB(S1)_")"))>3) D
     103 ;; .N D1,GLREF S GLREF=GL_D0_","_$$SUB(S1)_","
     104 ;; .S D1=0 F  S D1=$O(@(GLREF_D1_")")) Q:'D1  D GETREC(GLREF,PATH,D1,.REM)
     105 ;; ;
     106 ;; Q
     107 ;; ;
     108 ;;SUB(X) Q:'(X=+X) """"_X_"""" Q X
     109 ;; ;
     110 ;;DIQ(DIC,DA,OCXARY) ;
     111 ;; N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="EN" D EN^DIQ1
     112 ;; Q
     113 ;; ;
     114 ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
     115 ;; ;
     116 ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
     117 ;; ;
     118 ;;$
     119 ;1;
     120 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND5.m

    r613 r623  
    1 OCXSEND5        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 1) ;2/01/01  09:56
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N R,LINE,TEXT,NOW,RUCI
    8         S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
    9         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
    10         ;
    11         M ^TMP("OCXSEND",$J,"RTN")=R
    12         ;
    13         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(1,1)
    14         W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN")
    15         ;
    16         Q " "
    17         ;
    18 TEXT    ;
    19         ;;|$$RNAME^OCXSEND3(1,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    20         ;;|OCXLIN2|
    21         ;;|OCXLIN3|
    22         ;; ;
    23         ;;S ;
    24         ;; ;
    25         ;; Q
    26         ;; ;
    27         ;; ;
    28         ;;COMPARE(L,R) ;
    29         ;; ;
    30         ;; Q:$$RES("R") 1
    31         ;; ;
    32         ;; Q:'$L($O(L(""))) $$ADDREC^|$$RNAME^OCXSEND3(2,1)|("R")
    33         ;; ;
    34         ;; N C,OCXDD M C=L,C=R S OCXDD=$O(C("")) Q $$MULT("C",OCXDD)
    35         ;; ;
    36         ;; Q 0
    37         ;; ;
    38         ;;RES(REF) ;
    39         ;; ;
    40         ;; N QUIT,SUB
    41         ;; S QUIT=0
    42         ;; S SUB="" F  S SUB=$O(@REF@(SUB)) Q:'$L(SUB)  I (SUB[":") D  Q:QUIT
    43         ;; .N DD,DA
    44         ;; .S DD=$P(SUB,":",1),DA=$P(SUB,":",2)
    45         ;; .I $L(DA),'(DA=+DA) D  Q:QUIT
    46         ;; ..N DANEW,SUBNEW
    47         ;; ..S DANEW=$O(^OCXS($P(DA,U,2),"B",$P(DA,U,1),0))
    48         ;; ..I 'DANEW W !!,$P($G(^OCXS(+$P(DA,U,2),0)),U,1),": ",$P(DA,U,1),"  could not resolve name.",!!,"    End Transport." S QUIT=1 Q
    49         ;; ..S SUBNEW=DD_":"_DANEW
    50         ;; ..I $D(@REF@(SUBNEW)) W !!," multiple #",DANEW," already existed." S QUIT=1 Q
    51         ;; ..M @REF@(SUBNEW)=@REF@(SUB)
    52         ;; ..K @REF@(SUB)
    53         ;; ..S SUB=""
    54         ;; .I $L(SUB),($D(@REF@(SUB))>9) S QUIT=$$RES($NA(@REF@(SUB)))
    55         ;; ;
    56         ;; Q QUIT
    57         ;; ;
    58         ;;MULT(CREF,OCXDD) ;
    59         ;; ;
    60         ;; N OCXSUB,LREF,RREF,QUIT,OCXFLD
    61         ;; S LREF="L"_$E(CREF,2,$L(CREF)),RREF="R"_$E(CREF,2,$L(CREF))
    62         ;; ;
    63         ;; S QUIT=0,OCXFLD="" F  S OCXFLD=$O(@CREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  D  Q:QUIT
    64         ;; .I (OCXFLD[":") D  Q:QUIT
    65         ;; ..Q:$$EXFLD(+OCXFLD,0)
    66         ;; ..I '$D(@LREF@(OCXDD,OCXFLD,.01,"E")) D  M @LREF@(OCXDD,OCXFLD)=@RREF@(OCXDD,OCXFLD)
    67         ;; ...D WARN("Missing multiple:",CREF,OCXDD,OCXFLD)
    68         ;; ...S QUIT=$$ADDMULT^|$$RNAME^OCXSEND3(3,1)|(CREF,OCXDD,OCXFLD)
    69         ;; ..I '$D(@RREF@(OCXDD,OCXFLD,.01,"E")) D  M @RREF@(OCXDD,OCXFLD)=@LREF@(OCXDD,OCXFLD)
    70         ;; ...D WARN("Extra multiple:",CREF,OCXDD,OCXFLD)
    71         ;; ...S QUIT=$$DELMULT^|$$RNAME^OCXSEND3(3,1)|($$APPEND(CREF,OCXDD),OCXFLD)
    72         ;; .;
    73         ;; .I (OCXFLD=+OCXFLD),'$$EXFLD(+OCXDD,OCXFLD) D
    74         ;; ..I ($O(@CREF@(OCXDD,OCXFLD,""))="E") D  Q
    75         ;; ...I $L($G(@RREF@(OCXDD,OCXFLD,"E"))),'$L($G(@LREF@(OCXDD,OCXFLD,"E"))) D  Q
    76         ;; ....D WARN("Data Value Missing in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E")
    77         ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E")
    78         ;; ...I $L($G(@LREF@(OCXDD,OCXFLD,"E"))),'$L($G(@RREF@(OCXDD,OCXFLD,"E"))) D  Q
    79         ;; ....D WARN("Extra Data Value in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E")
    80         ;; ....S QUIT=$$DELFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E")
    81         ;; ...I '(@LREF@(OCXDD,OCXFLD,"E")=@RREF@(OCXDD,OCXFLD,"E")) D
    82         ;; ....D WARN("Inconsistent Data",CREF,OCXDD,OCXFLD,"E")
    83         ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E")
    84         ;; ..S OCXSUB=0 F  Q:QUIT  S OCXSUB=$O(@CREF@(OCXDD,OCXFLD,OCXSUB)) Q:'OCXSUB  I '($G(@RREF@(OCXDD,OCXFLD,OCXSUB))=$G(@LREF@(OCXDD,OCXFLD,OCXSUB))) D  Q
    85         ;; ...D WARN("Inconsistent word Data",CREF,OCXDD,OCXFLD,OCXSUB)
    86         ;; ...S QUIT=$$LOADWORD^|$$RNAME^OCXSEND3(2,1)|(RREF,OCXDD,OCXFLD,OCXSUB)
    87         ;; .;
    88         ;; .I 'QUIT,(OCXFLD[":") S QUIT=$$MULT($$APPEND(CREF,OCXDD),OCXFLD)
    89         ;; Q QUIT
    90         ;; ;
    91         ;;APPEND(ARRAY,OCXSUB) ;
    92         ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
    93         ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
    94         ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
    95         ;; ;
    96         ;;EXFLD(FILE,OCXFLD) ;
    97         ;; N OCXFNAM
    98         ;; S OCXFNAM=$$FIELD^OCXSENDD(FILE,OCXFLD,"LABEL")
    99         ;; I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1
    100         ;; I (FILE=860.2),(OCXFLD=.02) Q 1
    101         ;; I (FILE=860.22),(OCXFLD=4) Q 1
    102         ;; I (FILE=860.3),(OCXFLD=3) Q 1
    103         ;; I (FILE=860.9),(OCXFLD=1) Q 1
    104         ;; I (FILE=860.91) Q 1
    105         ;; I (FILE=860.801) Q 1
    106         ;; I (FILE=860.81) Q 1
    107         ;; I (FILE=861.01) Q 1
    108         ;; I (FILE=863.02) Q 1
    109         ;; I (FILE=863.54) Q 1
    110         ;; I (FILE=863.61) Q 1
    111         ;; I (FILE=863.72) Q 1
    112         ;; I (FILE=863.81) Q 1
    113         ;; I ($E(OCXFNAM,1)="*") Q 1
    114         ;; Q 0
    115         ;; ;
    116         ;;WARN(MSG,CREF,OCXDD,OCXFLD,OCXSUB) ;
    117         ;; ;
    118         ;; Q:$G(OCXAUTO)
    119         ;; ;
    120         ;; N D0,DASH,OCXDDPTH,OCXDPTR,FILE,FILEID,LREF,OCXPTR,RREF
    121         ;; ;
    122         ;; S DASH="",$P(DASH,"-",(55-$L(MSG)))="-"
    123         ;; W !!,"------------",MSG,DASH
    124         ;; D DSPHDR(CREF,OCXDD,OCXFLD)
    125         ;; I $D(OCXSUB) D DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB)
    126         ;; I '$D(OCXSUB) D DSPREC(CREF,OCXDD,OCXFLD)
    127         ;; ;
    128         ;; W ! Q
    129         ;; ;
    130         ;;DSPREC(CREF,OCXDD,OCXFLD) ;
    131         ;; ;
    132         ;; N OCXDPTR,OCXDDPTH,LEVL,OCXCREF,OCXSUB
    133         ;; S OCXCREF=$$APPEND($$APPEND(CREF,OCXDD),OCXFLD)
    134         ;; S OCXDDPTH=$P($P(OCXCREF,"(",2),")",1),LEVL=$L(OCXDDPTH,",")
    135         ;; S OCXSUB="" F  S OCXSUB=$O(@OCXCREF@(OCXSUB)) Q:'$L(OCXSUB)  D
    136         ;; .;
    137         ;; .I '(OCXSUB[":"),'((OCXSUB=.01)&$O(@OCXCREF@(OCXSUB))) D
    138         ;; ..N LINE
    139         ;; ..Q:$$EXFLD(+OCXFLD,OCXSUB)
    140         ;; ..I OCXFLD W !,?(5+((LEVL)*4)),$$FIELD^OCXSENDD(+OCXFLD,OCXSUB,"LABEL"),": ",$G(@OCXCREF@(OCXSUB,"E"))
    141         ;; ..S LINE=0 F  S LINE=$O(@OCXCREF@(OCXSUB,LINE)) Q:'LINE  D
    142         ;; ...W !,?(5+(LEVL*4)),$J(LINE,3),">",@OCXCREF@(OCXSUB,LINE)
    143         ;; .;
    144         ;; .I (OCXSUB[":") D
    145         ;; ..N D0,OCXDD,FILENAME
    146         ;; ..S D0=+$P(OCXSUB,":",2),OCXDD=+OCXSUB
    147         ;; ..S FILENAME=$$FILENAME^OCXSENDD(OCXDD)
    148         ;; ..I $L(FILENAME) W !,?(5+($L(LEVL)*4)),FILENAME
    149         ;; ..E  W !!,?(5+(LEVL*4)),FILENAME
    150         ;; ..W " ",D0,": ",$G(@OCXCREF@(OCXSUB,.01,"E"))
    151         ;; ..D DSPREC($$APPEND(CREF,OCXDD),OCXFLD,OCXSUB)
    152         ;; ;
    153         ;; Q
    154         ;; ;
    155         ;;DSPHDR(CREF,OCXDD,OCXFLD) ;
    156         ;; ;
    157         ;; N D0,FILE,FILEID,OCXPTR,OCXDDPTH
    158         ;; S OCXDDPTH=$P($P($$APPEND($$APPEND(CREF,OCXDD),OCXFLD),"(",2),")",1)
    159         ;; S FILE="" F OCXPTR=1:1:$L(OCXDDPTH,",") D
    160         ;; .N OCXDD,D0,FILEID
    161         ;; .S FILEID=$P(OCXDDPTH,",",OCXPTR)
    162         ;; .I (FILEID[":") D
    163         ;; ..S D0=+$P(FILEID,":",2),OCXDD=+$E(FILEID,2,$L(FILEID))
    164         ;; ..W !,?(5+(OCXPTR*4)),$$FILENAME^OCXSENDD(OCXDD)
    165         ;; ..S:$L(FILE) FILE=FILE_"," S FILE=FILE_FILEID
    166         ;; ..I $D(@("L("_FILE_",.01,""E"")")) W ": ",@("L("_FILE_",.01,""E"")") W:D0 " [",D0,"]"
    167         ;; ..E  I $D(@("R("_FILE_",.01,""E"")")) W ": ",@("R("_FILE_",.01,""E"")") W:D0 " [",D0,"]"
    168         ;; ;
    169         ;; Q
    170         ;; ;
    171         ;;DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) ;
    172         ;; ;
    173         ;; N OCXDPTR,LREF,RREF,OCXDDPTH
    174         ;; ;
    175         ;; S OCXDDPTH=$P($P($$APPEND(CREF,OCXDD),"(",2),")",1)
    176         ;; S LREF="L("_OCXDDPTH_")",RREF="R("_OCXDDPTH_")"
    177         ;; W !,?(5+(($L(OCXDDPTH,",")+1)*4)),$$FIELD^OCXSENDD(OCXDD,OCXFLD,"LABEL")," field [",OCXFLD,"]"
    178         ;; I OCXSUB W " Line #",OCXSUB
    179         ;; ;
    180         ;; W:($D(@RREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(R) |RUCI|: ",@RREF@(OCXFLD,OCXSUB)
    181         ;; W:($D(@LREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(L) ",$$NETNAME^OCXSEND,": ",@LREF@(OCXFLD,OCXSUB)
    182         ;; ;
    183         ;; Q
    184         ;; ;
    185         ;; W !,?10 Q 0 Q $$PAUSE
    186         ;; ;
    187         ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
    188         ;; ;
    189         ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
    190         ;; ;
    191         ;;$
    192         ;1;
    193         ;
     1OCXSEND5 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 1) ;2/01/01  09:56
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N R,LINE,TEXT,NOW,RUCI,XCM
     8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
     9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
     10 ;
     11 M ^TMP("OCXSEND",$J,"RTN")=R
     12 ;
     13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(1,1)
     14 W !,X X ^%ZOSF("SAVE") W "  ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN")
     15 ;
     16 Q XCM
     17 ;
     18TEXT ;
     19 ;;|$$RNAME^OCXSEND3(1,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     20 ;;|OCXLIN2|
     21 ;;|OCXLIN3|
     22 ;; ;
     23 ;;S ;
     24 ;; ;
     25 ;; Q
     26 ;; ;
     27 ;; ;
     28 ;;COMPARE(L,R) ;
     29 ;; ;
     30 ;; Q:$$RES("R") 1
     31 ;; ;
     32 ;; Q:'$L($O(L(""))) $$ADDREC^|$$RNAME^OCXSEND3(2,1)|("R")
     33 ;; ;
     34 ;; N C,OCXDD M C=L,C=R S OCXDD=$O(C("")) Q $$MULT("C",OCXDD)
     35 ;; ;
     36 ;; Q 0
     37 ;; ;
     38 ;;RES(REF) ;
     39 ;; ;
     40 ;; N QUIT,SUB
     41 ;; S QUIT=0
     42 ;; S SUB="" F  S SUB=$O(@REF@(SUB)) Q:'$L(SUB)  I (SUB[":") D  Q:QUIT
     43 ;; .N DD,DA
     44 ;; .S DD=$P(SUB,":",1),DA=$P(SUB,":",2)
     45 ;; .I $L(DA),'(DA=+DA) D  Q:QUIT
     46 ;; ..N DANEW,SUBNEW
     47 ;; ..S DANEW=$O(^OCXS($P(DA,U,2),"B",$P(DA,U,1),0))
     48 ;; ..I 'DANEW W !!,$P($G(^OCXS(+$P(DA,U,2),0)),U,1),": ",$P(DA,U,1),"  could not resolve name.",!!,"    End Transport." S QUIT=1 Q
     49 ;; ..S SUBNEW=DD_":"_DANEW
     50 ;; ..I $D(@REF@(SUBNEW)) W !!," multiple #",DANEW," already existed." S QUIT=1 Q
     51 ;; ..M @REF@(SUBNEW)=@REF@(SUB)
     52 ;; ..K @REF@(SUB)
     53 ;; ..S SUB=""
     54 ;; .I $L(SUB),($D(@REF@(SUB))>9) S QUIT=$$RES($NA(@REF@(SUB)))
     55 ;; ;
     56 ;; Q QUIT
     57 ;; ;
     58 ;;MULT(CREF,OCXDD) ;
     59 ;; ;
     60 ;; N OCXSUB,LREF,RREF,QUIT,OCXFLD
     61 ;; S LREF="L"_$E(CREF,2,$L(CREF)),RREF="R"_$E(CREF,2,$L(CREF))
     62 ;; ;
     63 ;; S QUIT=0,OCXFLD="" F  S OCXFLD=$O(@CREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  D  Q:QUIT
     64 ;; .I (OCXFLD[":") D  Q:QUIT
     65 ;; ..Q:$$EXFLD(+OCXFLD,0)
     66 ;; ..I '$D(@LREF@(OCXDD,OCXFLD,.01,"E")) D  M @LREF@(OCXDD,OCXFLD)=@RREF@(OCXDD,OCXFLD)
     67 ;; ...D WARN("Missing multiple:",CREF,OCXDD,OCXFLD)
     68 ;; ...S QUIT=$$ADDMULT^|$$RNAME^OCXSEND3(3,1)|(CREF,OCXDD,OCXFLD)
     69 ;; ..I '$D(@RREF@(OCXDD,OCXFLD,.01,"E")) D  M @RREF@(OCXDD,OCXFLD)=@LREF@(OCXDD,OCXFLD)
     70 ;; ...D WARN("Extra multiple:",CREF,OCXDD,OCXFLD)
     71 ;; ...S QUIT=$$DELMULT^|$$RNAME^OCXSEND3(3,1)|($$APPEND(CREF,OCXDD),OCXFLD)
     72 ;; .;
     73 ;; .I (OCXFLD=+OCXFLD),'$$EXFLD(+OCXDD,OCXFLD) D
     74 ;; ..I ($O(@CREF@(OCXDD,OCXFLD,""))="E") D  Q
     75 ;; ...I $L($G(@RREF@(OCXDD,OCXFLD,"E"))),'$L($G(@LREF@(OCXDD,OCXFLD,"E"))) D  Q
     76 ;; ....D WARN("Data Value Missing in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E")
     77 ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E")
     78 ;; ...I $L($G(@LREF@(OCXDD,OCXFLD,"E"))),'$L($G(@RREF@(OCXDD,OCXFLD,"E"))) D  Q
     79 ;; ....D WARN("Extra Data Value in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E")
     80 ;; ....S QUIT=$$DELFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E")
     81 ;; ...I '(@LREF@(OCXDD,OCXFLD,"E")=@RREF@(OCXDD,OCXFLD,"E")) D
     82 ;; ....D WARN("Inconsistent Data",CREF,OCXDD,OCXFLD,"E")
     83 ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E")
     84 ;; ..S OCXSUB=0 F  Q:QUIT  S OCXSUB=$O(@CREF@(OCXDD,OCXFLD,OCXSUB)) Q:'OCXSUB  I '($G(@RREF@(OCXDD,OCXFLD,OCXSUB))=$G(@LREF@(OCXDD,OCXFLD,OCXSUB))) D  Q
     85 ;; ...D WARN("Inconsistent word Data",CREF,OCXDD,OCXFLD,OCXSUB)
     86 ;; ...S QUIT=$$LOADWORD^|$$RNAME^OCXSEND3(2,1)|(RREF,OCXDD,OCXFLD,OCXSUB)
     87 ;; .;
     88 ;; .I 'QUIT,(OCXFLD[":") S QUIT=$$MULT($$APPEND(CREF,OCXDD),OCXFLD)
     89 ;; Q QUIT
     90 ;; ;
     91 ;;APPEND(ARRAY,OCXSUB) ;
     92 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
     93 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
     94 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
     95 ;; ;
     96 ;;EXFLD(FILE,OCXFLD) ;
     97 ;; N OCXFNAM
     98 ;; S OCXFNAM=$$FIELD^OCXSENDD(FILE,OCXFLD,"LABEL")
     99 ;; I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1
     100 ;; I (FILE=860.2),(OCXFLD=.02) Q 1
     101 ;; I (FILE=860.22),(OCXFLD=4) Q 1
     102 ;; I (FILE=860.3),(OCXFLD=3) Q 1
     103 ;; I (FILE=860.9),(OCXFLD=1) Q 1
     104 ;; I (FILE=860.91) Q 1
     105 ;; I (FILE=860.801) Q 1
     106 ;; I (FILE=860.81) Q 1
     107 ;; I (FILE=861.01) Q 1
     108 ;; I (FILE=863.02) Q 1
     109 ;; I (FILE=863.54) Q 1
     110 ;; I (FILE=863.61) Q 1
     111 ;; I (FILE=863.72) Q 1
     112 ;; I (FILE=863.81) Q 1
     113 ;; I ($E(OCXFNAM,1)="*") Q 1
     114 ;; Q 0
     115 ;; ;
     116 ;;WARN(MSG,CREF,OCXDD,OCXFLD,OCXSUB) ;
     117 ;; ;
     118 ;; Q:$G(OCXAUTO)
     119 ;; ;
     120 ;; N D0,DASH,OCXDDPTH,OCXDPTR,FILE,FILEID,LREF,OCXPTR,RREF
     121 ;; ;
     122 ;; S DASH="",$P(DASH,"-",(55-$L(MSG)))="-"
     123 ;; W !!,"------------",MSG,DASH
     124 ;; D DSPHDR(CREF,OCXDD,OCXFLD)
     125 ;; I $D(OCXSUB) D DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB)
     126 ;; I '$D(OCXSUB) D DSPREC(CREF,OCXDD,OCXFLD)
     127 ;; ;
     128 ;; W ! Q
     129 ;; ;
     130 ;;DSPREC(CREF,OCXDD,OCXFLD) ;
     131 ;; ;
     132 ;; N OCXDPTR,OCXDDPTH,LEVL,OCXCREF,OCXSUB
     133 ;; S OCXCREF=$$APPEND($$APPEND(CREF,OCXDD),OCXFLD)
     134 ;; S OCXDDPTH=$P($P(OCXCREF,"(",2),")",1),LEVL=$L(OCXDDPTH,",")
     135 ;; S OCXSUB="" F  S OCXSUB=$O(@OCXCREF@(OCXSUB)) Q:'$L(OCXSUB)  D
     136 ;; .;
     137 ;; .I '(OCXSUB[":"),'((OCXSUB=.01)&$O(@OCXCREF@(OCXSUB))) D
     138 ;; ..N LINE
     139 ;; ..Q:$$EXFLD(+OCXFLD,OCXSUB)
     140 ;; ..I OCXFLD W !,?(5+((LEVL)*4)),$$FIELD^OCXSENDD(+OCXFLD,OCXSUB,"LABEL"),": ",$G(@OCXCREF@(OCXSUB,"E"))
     141 ;; ..S LINE=0 F  S LINE=$O(@OCXCREF@(OCXSUB,LINE)) Q:'LINE  D
     142 ;; ...W !,?(5+(LEVL*4)),$J(LINE,3),">",@OCXCREF@(OCXSUB,LINE)
     143 ;; .;
     144 ;; .I (OCXSUB[":") D
     145 ;; ..N D0,OCXDD,FILENAME
     146 ;; ..S D0=+$P(OCXSUB,":",2),OCXDD=+OCXSUB
     147 ;; ..S FILENAME=$$FILENAME^OCXSENDD(OCXDD)
     148 ;; ..I $L(FILENAME) W !,?(5+($L(LEVL)*4)),FILENAME
     149 ;; ..E  W !!,?(5+(LEVL*4)),FILENAME
     150 ;; ..W " ",D0,": ",$G(@OCXCREF@(OCXSUB,.01,"E"))
     151 ;; ..D DSPREC($$APPEND(CREF,OCXDD),OCXFLD,OCXSUB)
     152 ;; ;
     153 ;; Q
     154 ;; ;
     155 ;;DSPHDR(CREF,OCXDD,OCXFLD) ;
     156 ;; ;
     157 ;; N D0,FILE,FILEID,OCXPTR,OCXDDPTH
     158 ;; S OCXDDPTH=$P($P($$APPEND($$APPEND(CREF,OCXDD),OCXFLD),"(",2),")",1)
     159 ;; S FILE="" F OCXPTR=1:1:$L(OCXDDPTH,",") D
     160 ;; .N OCXDD,D0,FILEID
     161 ;; .S FILEID=$P(OCXDDPTH,",",OCXPTR)
     162 ;; .I (FILEID[":") D
     163 ;; ..S D0=+$P(FILEID,":",2),OCXDD=+$E(FILEID,2,$L(FILEID))
     164 ;; ..W !,?(5+(OCXPTR*4)),$$FILENAME^OCXSENDD(OCXDD)
     165 ;; ..S:$L(FILE) FILE=FILE_"," S FILE=FILE_FILEID
     166 ;; ..I $D(@("L("_FILE_",.01,""E"")")) W ": ",@("L("_FILE_",.01,""E"")") W:D0 " [",D0,"]"
     167 ;; ..E  I $D(@("R("_FILE_",.01,""E"")")) W ": ",@("R("_FILE_",.01,""E"")") W:D0 " [",D0,"]"
     168 ;; ;
     169 ;; Q
     170 ;; ;
     171 ;;DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) ;
     172 ;; ;
     173 ;; N OCXDPTR,LREF,RREF,OCXDDPTH
     174 ;; ;
     175 ;; S OCXDDPTH=$P($P($$APPEND(CREF,OCXDD),"(",2),")",1)
     176 ;; S LREF="L("_OCXDDPTH_")",RREF="R("_OCXDDPTH_")"
     177 ;; W !,?(5+(($L(OCXDDPTH,",")+1)*4)),$$FIELD^OCXSENDD(OCXDD,OCXFLD,"LABEL")," field [",OCXFLD,"]"
     178 ;; I OCXSUB W " Line #",OCXSUB
     179 ;; ;
     180 ;; W:($D(@RREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(R) |RUCI|: ",@RREF@(OCXFLD,OCXSUB)
     181 ;; W:($D(@LREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(L) ",$$NETNAME^OCXSEND,": ",@LREF@(OCXFLD,OCXSUB)
     182 ;; ;
     183 ;; Q
     184 ;; ;
     185 ;; W !,?10 Q 0 Q $$PAUSE
     186 ;; ;
     187 ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
     188 ;; ;
     189 ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
     190 ;; ;
     191 ;;$
     192 ;1;
     193 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND6.m

    r613 r623  
    1 OCXSEND6        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 2) ;2/01/01  10:03
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,76,74,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N R,LINE,TEXT,NOW,RUCI
    8         S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
    9         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
    10         ;
    11         M ^TMP("OCXSEND",$J,"RTN")=R
    12         ;
    13         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(2,1)
    14         W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN")
    15         ;
    16         Q " "
    17         ;
    18 TEXT    ;
    19         ;;|$$RNAME^OCXSEND3(2,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    20         ;;|OCXLIN2|
    21         ;;|OCXLIN3|
    22         ;; ;
    23         ;;S ;
    24         ;; ;  Record Utilities
    25         ;; Q
    26         ;; ;
    27         ;;ADDREC(OCXCREF) ;
    28         ;; ;
    29         ;; N QUIT,OCXDD,OCXDA,OCXGREF,OCXNAME
    30         ;; S OCXDD=$O(@OCXCREF@("")) Q:'OCXDD 0
    31         ;; S OCXNAME=$G(@OCXCREF@(OCXDD,.01,"E"))
    32         ;; ;
    33         ;; W "   record missing..."
    34         ;; I (OCXFLAG["D") Q 0
    35         ;; ;
    36         ;; S OCXDA=0 D CREATE(OCXCREF,OCXDD,.OCXDA,0)
    37         ;; S:$L(OCXNAME) ^TMP("OCXRULE",$J,"A",+OCXDD,OCXNAME)=""
    38         ;; ;
    39         ;; Q 0
    40         ;; ;
    41         ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ;
    42         ;; ;
    43         ;; N OCXFLD,OCXGREF,OCXKEY
    44         ;; ;
    45         ;; I $L(OCXDA),'(OCXDA=+OCXDA) W !!,"Unresolved subscript." Q
    46         ;; ;
    47         ;; S OCXKEY=@OCXCREF@(OCXDD,.01,"E")
    48         ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF)
    49         ;; I 'OCXDA D
    50         ;; .S OCXDA=$O(^TMP("OCXRULE",$J,"B",+OCXDD,OCXKEY,0)) Q:OCXDA
    51         ;; .S OCXDA=$O(@(OCXGREF_""" "")"),-1)+1
    52         ;; .F OCXDA=OCXDA:1 Q:'$D(@(OCXGREF_OCXDA_",0)"))
    53         ;; .I $D(@(OCXGREF_OCXDA_",0)")) S OCXDA=0
    54         ;; ;
    55         ;; I 'OCXDA W !!,"Error adding record..." Q
    56         ;; ;
    57         ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U
    58         ;; ;
    59         ;; S OCXFLD=0 F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD  Q:(OCXFLD[":")  I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D
    60         ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL)
    61         ;; .I $O(@OCXCREF@(OCXDD,OCXFLD,0)) D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,OCXCREF)
    62         ;; ;
    63         ;; D PUSH(.OCXDA)
    64         ;; S OCXFLD="" F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  I (OCXFLD[":") D
    65         ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1)
    66         ;; D POP(.OCXDA)
    67         ;; Q
    68         ;; ;
    69         ;;LOADWORD(RREF,OCXDD,OCXFLD,OCXSUB) ;
    70         ;; ;
    71         ;; N QUIT,DDPATH,INDEX,OCXDA,OCXGREF
    72         ;; S DDPATH=$P($P($$APPEND(RREF,OCXDD),"(",2),")",1)
    73         ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2)
    74         ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0)
    75         ;; Q:(OCXFLAG["D") 0
    76         ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to reload the local '"_$$FIELD^OCXSENDD(+OCXDD,+OCXFLD,"LABEL")_"' field ?","YES") Q:'QUIT (QUIT[U)
    77         ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,$L(DDPATH,",")-1) Q:'$L(OCXGREF)
    78         ;; D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,RREF)
    79         ;; Q 0
    80         ;; ;
    81         ;;GETREF(OCXDD,OCXDA,OCXLVL) ;
    82         ;; ;
    83         ;; Q:'OCXDD ""
    84         ;; ;
    85         ;; N OCXIENS,OCXERR,OCXX
    86         ;; S OCXIENS=$$IENS^DILF(.OCXDA),OCXERR=""
    87         ;; S OCXX=$$ROOT^DILFD(OCXDD,OCXIENS,0,OCXERR)
    88         ;; Q OCXX
    89         ;; ;
    90         ;;WORD(DD,GREF,FLD,DA,RREF) ;
    91         ;; ;
    92         ;; N SUB,GLROOT,LINE
    93         ;; S SUB=$P($$FIELD^OCXSENDD(+DD,FLD,"GLOBAL SUBSCRIPT LOCATION"),";",1) S:'(SUB=+SUB) SUB=""""_SUB_""""
    94         ;; S GLROOT=GREF_DA_","_SUB_")" K @GLROOT
    95         ;; S LINE=0 F  S LINE=$O(@RREF@(DD,FLD,LINE)) Q:'LINE  D
    96         ;; .S @GLROOT@($O(@GLROOT@(""),-1)+1,0)=@RREF@(DD,FLD,LINE)
    97         ;; S LINE=$O(@GLROOT@(""),-1),@GLROOT@(0)=U_U_LINE_U_LINE_U_$$DATE("T")_U
    98         ;; ;
    99         ;; Q
    100         ;; ;
    101         ;;DATE(X) N %DT,Y S %DT="" D ^%DT Q +Y
    102         ;; ;
    103         ;;DIE(OCXDD,OCXDIC,OCXFLD,OCXVAL,OCXDA,OCXLVL) ;
    104         ;; ;
    105         ;; N DIC,DIE,X,Y,DR,DA,OCXDVAL,OCXPTR,OCXGREF,D0,OCXSCR
    106         ;; S (D0,DA)=OCXDA,(DIC,DIE)=OCXDIC,DR=""
    107         ;; S:OCXLVL D0=OCXDA(1),DR="S DA(1)="_(+D0)_",D0="_(+D0)_";"
    108         ;; S:OCXVAL="?" OCXVAL="? " S DR=DR_OCXFLD_"///^S X=OCXVAL"
    109         ;; I '(OCXVAL="@") W !,?(OCXLVL*5),$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"LABEL"),": ",OCXVAL
    110         ;; ;
    111         ;; I '(OCXVAL="@") D
    112         ;; .N OCXIEN,SHORT
    113         ;; .S OCXPTR=+$P($$FIELD^OCXSENDD(+OCXDD,OCXFLD,"SPECIFIER"),"P",2)
    114         ;; .Q:'OCXPTR
    115         ;; .S OCXGREF="^"_$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"POINTER")
    116         ;; .I '($E(OCXGREF,1,4)="^OCX"),'(OCXGREF="^ORD(100.9,"),'(OCXGREF="^ORD(100.8,") Q
    117         ;; .Q:$$DIC(OCXGREF,OCXVAL,0)
    118         ;; .S OCXIEN=$$DIC(OCXGREF,OCXVAL,1)
    119         ;; .S ^TMP("OCXRULE",$J,"B",OCXPTR,OCXVAL,OCXIEN)=""
    120         ;; ;
    121         ;; S OCXSCR=1
    122         ;; D ^DIE
    123         ;; ;
    124         ;; ; I $D(Y) -> DIE FILER ERROR
    125         ;; I $D(Y) W "   ^DIE filer data error..." S OCXDIER=$G(OCXDIER)+1
    126         ;; I '$D(Y) W "    ...Correct data Filed"
    127         ;; ;
    128         ;; Q
    129         ;; ;
    130         ;;DIC(DIC,X,OCXADD) N OCXSCR S DIC(0)="",OCXSCR=1 S:OCXADD DIC(0)="L" D ^DIC Q:(+Y>0) +Y Q 0
    131         ;; ;
    132         ;;PUSH(OCXDA) ;
    133         ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB  S OCXDA(OCXSUB+1)=OCXDA(OCXSUB)
    134         ;; S OCXDA(1)=OCXDA,OCXDA=0
    135         ;; Q
    136         ;; ;
    137         ;;POP(OCXDA) ;
    138         ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB  S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1))
    139         ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1))
    140         ;; Q
    141         ;; ;
    142         ;;APPEND(ARRAY,OCXSUB) ;
    143         ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
    144         ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
    145         ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
    146         ;; ;
    147         ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
    148         ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    149         ;; Q:'$L($G(OCXZ0)) U
    150         ;; S DIR(0)=OCXZ0
    151         ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
    152         ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
    153         ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
    154         ;; D ^DIR
    155         ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    156         ;; Q Y
    157         ;; ;
    158         ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
    159         ;; ;
    160         ;;$
    161         ;1;
    162         ;
     1OCXSEND6 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 2) ;2/01/01  10:03
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,76,74,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N R,LINE,TEXT,NOW,RUCI,XCM
     8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
     9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
     10 ;
     11 M ^TMP("OCXSEND",$J,"RTN")=R
     12 ;
     13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(2,1)
     14 W !,X X ^%ZOSF("SAVE") W "  ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN")
     15 ;
     16 Q XCM
     17 ;
     18TEXT ;
     19 ;;|$$RNAME^OCXSEND3(2,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     20 ;;|OCXLIN2|
     21 ;;|OCXLIN3|
     22 ;; ;
     23 ;;S ;
     24 ;; ;  Record Utilities
     25 ;; Q
     26 ;; ;
     27 ;;ADDREC(OCXCREF) ;
     28 ;; ;
     29 ;; N QUIT,OCXDD,OCXDA,OCXGREF,OCXNAME
     30 ;; S OCXDD=$O(@OCXCREF@("")) Q:'OCXDD 0
     31 ;; S OCXNAME=$G(@OCXCREF@(OCXDD,.01,"E"))
     32 ;; ;
     33 ;; W "   record missing..."
     34 ;; I (OCXFLAG["D") Q 0
     35 ;; ;
     36 ;; S OCXDA=0 D CREATE(OCXCREF,OCXDD,.OCXDA,0)
     37 ;; S:$L(OCXNAME) ^TMP("OCXRULE",$J,"A",+OCXDD,OCXNAME)=""
     38 ;; ;
     39 ;; Q 0
     40 ;; ;
     41 ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ;
     42 ;; ;
     43 ;; N OCXFLD,OCXGREF,OCXKEY
     44 ;; ;
     45 ;; I $L(OCXDA),'(OCXDA=+OCXDA) W !!,"Unresolved subscript." Q
     46 ;; ;
     47 ;; S OCXKEY=@OCXCREF@(OCXDD,.01,"E")
     48 ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF)
     49 ;; I 'OCXDA D
     50 ;; .S OCXDA=$O(^TMP("OCXRULE",$J,"B",+OCXDD,OCXKEY,0)) Q:OCXDA
     51 ;; .S OCXDA=$O(@(OCXGREF_""" "")"),-1)+1
     52 ;; .F OCXDA=OCXDA:1 Q:'$D(@(OCXGREF_OCXDA_",0)"))
     53 ;; .I $D(@(OCXGREF_OCXDA_",0)")) S OCXDA=0
     54 ;; ;
     55 ;; I 'OCXDA W !!,"Error adding record..." Q
     56 ;; ;
     57 ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U
     58 ;; ;
     59 ;; S OCXFLD=0 F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD  Q:(OCXFLD[":")  I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D
     60 ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL)
     61 ;; .I $O(@OCXCREF@(OCXDD,OCXFLD,0)) D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,OCXCREF)
     62 ;; ;
     63 ;; D PUSH(.OCXDA)
     64 ;; S OCXFLD="" F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  I (OCXFLD[":") D
     65 ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1)
     66 ;; D POP(.OCXDA)
     67 ;; Q
     68 ;; ;
     69 ;;LOADWORD(RREF,OCXDD,OCXFLD,OCXSUB) ;
     70 ;; ;
     71 ;; N QUIT,DDPATH,INDEX,OCXDA,OCXGREF
     72 ;; S DDPATH=$P($P($$APPEND(RREF,OCXDD),"(",2),")",1)
     73 ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2)
     74 ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0)
     75 ;; Q:(OCXFLAG["D") 0
     76 ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to reload the local '"_$$FIELD^OCXSENDD(+OCXDD,+OCXFLD,"LABEL")_"' field ?","YES") Q:'QUIT (QUIT[U)
     77 ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,$L(DDPATH,",")-1) Q:'$L(OCXGREF)
     78 ;; D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,RREF)
     79 ;; Q 0
     80 ;; ;
     81 ;;GETREF(OCXDD,OCXDA,OCXLVL) ;
     82 ;; ;
     83 ;; Q:'OCXDD ""
     84 ;; ;
     85 ;; N OCXIENS,OCXERR,OCXX
     86 ;; S OCXIENS=$$IENS^DILF(.OCXDA),OCXERR=""
     87 ;; S OCXX=$$ROOT^DILFD(OCXDD,OCXIENS,0,OCXERR)
     88 ;; Q OCXX
     89 ;; ;
     90 ;;WORD(DD,GREF,FLD,DA,RREF) ;
     91 ;; ;
     92 ;; N SUB,GLROOT,LINE
     93 ;; S SUB=$P($$FIELD^OCXSENDD(+DD,FLD,"GLOBAL SUBSCRIPT LOCATION"),";",1) S:'(SUB=+SUB) SUB=""""_SUB_""""
     94 ;; S GLROOT=GREF_DA_","_SUB_")" K @GLROOT
     95 ;; S LINE=0 F  S LINE=$O(@RREF@(DD,FLD,LINE)) Q:'LINE  D
     96 ;; .S @GLROOT@($O(@GLROOT@(""),-1)+1,0)=@RREF@(DD,FLD,LINE)
     97 ;; S LINE=$O(@GLROOT@(""),-1),@GLROOT@(0)=U_U_LINE_U_LINE_U_$$DATE("T")_U
     98 ;; ;
     99 ;; Q
     100 ;; ;
     101 ;;DATE(X) N %DT,Y S %DT="" D ^%DT Q +Y
     102 ;; ;
     103 ;;DIE(OCXDD,OCXDIC,OCXFLD,OCXVAL,OCXDA,OCXLVL) ;
     104 ;; ;
     105 ;; N DIC,DIE,X,Y,DR,DA,OCXDVAL,OCXPTR,OCXGREF,D0,OCXSCR
     106 ;; S (D0,DA)=OCXDA,(DIC,DIE)=OCXDIC,DR=""
     107 ;; S:OCXLVL D0=OCXDA(1),DR="S DA(1)="_(+D0)_",D0="_(+D0)_";"
     108 ;; S:OCXVAL="?" OCXVAL="? " S DR=DR_OCXFLD_"///^S X=OCXVAL"
     109 ;; I '(OCXVAL="@") W !,?(OCXLVL*5),$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"LABEL"),": ",OCXVAL
     110 ;; ;
     111 ;; I '(OCXVAL="@") D
     112 ;; .N OCXIEN,SHORT
     113 ;; .S OCXPTR=+$P($$FIELD^OCXSENDD(+OCXDD,OCXFLD,"SPECIFIER"),"P",2)
     114 ;; .Q:'OCXPTR
     115 ;; .S OCXGREF="^"_$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"POINTER")
     116 ;; .I '($E(OCXGREF,1,4)="^OCX"),'(OCXGREF="^ORD(100.9,"),'(OCXGREF="^ORD(100.8,") Q
     117 ;; .Q:$$DIC(OCXGREF,OCXVAL,0)
     118 ;; .S OCXIEN=$$DIC(OCXGREF,OCXVAL,1)
     119 ;; .S ^TMP("OCXRULE",$J,"B",OCXPTR,OCXVAL,OCXIEN)=""
     120 ;; ;
     121 ;; S OCXSCR=1
     122 ;; D ^DIE
     123 ;; ;
     124 ;; ; I $D(Y) -> DIE FILER ERROR
     125 ;; I $D(Y) W "   ^DIE filer data error..." S OCXDIER=$G(OCXDIER)+1
     126 ;; I '$D(Y) W "    ...Correct data Filed"
     127 ;; ;
     128 ;; Q
     129 ;; ;
     130 ;;DIC(DIC,X,OCXADD) N OCXSCR S DIC(0)="",OCXSCR=1 S:OCXADD DIC(0)="L" D ^DIC Q:(+Y>0) +Y Q 0
     131 ;; ;
     132 ;;PUSH(OCXDA) ;
     133 ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB  S OCXDA(OCXSUB+1)=OCXDA(OCXSUB)
     134 ;; S OCXDA(1)=OCXDA,OCXDA=0
     135 ;; Q
     136 ;; ;
     137 ;;POP(OCXDA) ;
     138 ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB  S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1))
     139 ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1))
     140 ;; Q
     141 ;; ;
     142 ;;APPEND(ARRAY,OCXSUB) ;
     143 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
     144 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
     145 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
     146 ;; ;
     147 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
     148 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     149 ;; Q:'$L($G(OCXZ0)) U
     150 ;; S DIR(0)=OCXZ0
     151 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
     152 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
     153 ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
     154 ;; D ^DIR
     155 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     156 ;; Q Y
     157 ;; ;
     158 ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
     159 ;; ;
     160 ;;$
     161 ;1;
     162 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND7.m

    r613 r623  
    1 OCXSEND7        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 3) ;1/31/01  11:07
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N R,LINE,TEXT,NOW,RUCI
    8         S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
    9         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
    10         ;
    11         M ^TMP("OCXSEND",$J,"RTN")=R
    12         ;
    13         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(3,1)
    14         W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN")
    15         ;
    16         Q " "
    17         ;
    18 TEXT    ;
    19         ;;|$$RNAME^OCXSEND3(3,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    20         ;;|OCXLIN2|
    21         ;;|OCXLIN3|
    22         ;; ;
    23         ;;S ;
    24         ;; ;  Multiple Utilities
    25         ;; Q
    26         ;; ;
    27         ;;ADDMULT(OCXCREF,OCXDD,OCXFLD) ;
    28         ;; ;
    29         ;; ;
    30         ;; N QUIT,OCXDA,OCXGREF,OCXNAME,DDPATH,INDEX
    31         ;; ;
    32         ;; S DDPATH=$P($P($$APPEND($$APPEND(OCXCREF,OCXDD),OCXFLD),"(",2),")",1)
    33         ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2)
    34         ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0)
    35         ;; ;
    36         ;; Q:(OCXFLAG["D") 0
    37         ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to add a local '"_$$FILENAME^OCXSENDD(+OCXFLD)_"' multiple ?","YES") Q:'QUIT (QUIT[U)
    38         ;; ;
    39         ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXFLD,.OCXDA,1)
    40         ;; D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,1)
    41         ;; ;
    42         ;; Q 0
    43         ;; ;
    44         ;;DELMULT(OCXCREF,OCXDD) ;
    45         ;; ;
    46         ;; N QUIT,OCXGREF,DA,INDEX,DDPATH
    47         ;; ;
    48         ;; Q:(OCXFLAG["D") 0
    49         ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' multiple ?","YES") Q:'QUIT (QUIT[U)
    50         ;; ;
    51         ;; S DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1)
    52         ;; F INDEX=1:1:$L(DDPATH,",") S DA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2)
    53         ;; S DA=$G(DA(0)) K DA(0)
    54         ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.DA,1)
    55         ;; ;
    56         ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,OCXGREF,.01,"@",.DA,$L(DDPATH,",")-1)
    57         ;; K @OCXCREF@(OCXDD) W !!,"  deleted..."
    58         ;; ;
    59         ;; Q 0
    60         ;; ;
    61         ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ;
    62         ;; ;
    63         ;; N OCXFLD,OCXGREF
    64         ;; ;
    65         ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF)  S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1
    66         ;; ;
    67         ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U
    68         ;; ;
    69         ;; S OCXFLD=0 F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD  Q:(OCXFLD[":")  I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D
    70         ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL)
    71         ;; ;
    72         ;; D PUSH(.OCXDA)
    73         ;; S OCXFLD="" F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  I (OCXFLD[":") D
    74         ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1)
    75         ;; D POP(.OCXDA)
    76         ;; Q
    77         ;; ;
    78         ;;PUSH(OCXDA) ;
    79         ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB  S OCXDA(OCXSUB+1)=OCXDA(OCXSUB)
    80         ;; S OCXDA(1)=OCXDA,OCXDA=0
    81         ;; Q
    82         ;; ;
    83         ;;POP(OCXDA) ;
    84         ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB  S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1))
    85         ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1))
    86         ;; Q
    87         ;; ;
    88         ;;APPEND(ARRAY,OCXSUB) ;
    89         ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
    90         ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
    91         ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
    92         ;; ;
    93         ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
    94         ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    95         ;; Q:'$L($G(OCXZ0)) U
    96         ;; S DIR(0)=OCXZ0
    97         ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
    98         ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
    99         ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
    100         ;; D ^DIR
    101         ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    102         ;; Q Y
    103         ;; ;
    104         ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
    105         ;; ;
    106         ;;$
    107         ;1;
    108         ;
     1OCXSEND7 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 3) ;1/31/01  11:07
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N R,LINE,TEXT,NOW,RUCI,XCM
     8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
     9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
     10 ;
     11 M ^TMP("OCXSEND",$J,"RTN")=R
     12 ;
     13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(3,1)
     14 W !,X X ^%ZOSF("SAVE") W "  ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN")
     15 ;
     16 Q XCM
     17 ;
     18TEXT ;
     19 ;;|$$RNAME^OCXSEND3(3,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     20 ;;|OCXLIN2|
     21 ;;|OCXLIN3|
     22 ;; ;
     23 ;;S ;
     24 ;; ;  Multiple Utilities
     25 ;; Q
     26 ;; ;
     27 ;;ADDMULT(OCXCREF,OCXDD,OCXFLD) ;
     28 ;; ;
     29 ;; ;
     30 ;; N QUIT,OCXDA,OCXGREF,OCXNAME,DDPATH,INDEX
     31 ;; ;
     32 ;; S DDPATH=$P($P($$APPEND($$APPEND(OCXCREF,OCXDD),OCXFLD),"(",2),")",1)
     33 ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2)
     34 ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0)
     35 ;; ;
     36 ;; Q:(OCXFLAG["D") 0
     37 ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to add a local '"_$$FILENAME^OCXSENDD(+OCXFLD)_"' multiple ?","YES") Q:'QUIT (QUIT[U)
     38 ;; ;
     39 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXFLD,.OCXDA,1)
     40 ;; D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,1)
     41 ;; ;
     42 ;; Q 0
     43 ;; ;
     44 ;;DELMULT(OCXCREF,OCXDD) ;
     45 ;; ;
     46 ;; N QUIT,OCXGREF,DA,INDEX,DDPATH
     47 ;; ;
     48 ;; Q:(OCXFLAG["D") 0
     49 ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' multiple ?","YES") Q:'QUIT (QUIT[U)
     50 ;; ;
     51 ;; S DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1)
     52 ;; F INDEX=1:1:$L(DDPATH,",") S DA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2)
     53 ;; S DA=$G(DA(0)) K DA(0)
     54 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.DA,1)
     55 ;; ;
     56 ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,OCXGREF,.01,"@",.DA,$L(DDPATH,",")-1)
     57 ;; K @OCXCREF@(OCXDD) W !!,"  deleted..."
     58 ;; ;
     59 ;; Q 0
     60 ;; ;
     61 ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ;
     62 ;; ;
     63 ;; N OCXFLD,OCXGREF
     64 ;; ;
     65 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF)  S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1
     66 ;; ;
     67 ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U
     68 ;; ;
     69 ;; S OCXFLD=0 F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD  Q:(OCXFLD[":")  I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D
     70 ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL)
     71 ;; ;
     72 ;; D PUSH(.OCXDA)
     73 ;; S OCXFLD="" F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  I (OCXFLD[":") D
     74 ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1)
     75 ;; D POP(.OCXDA)
     76 ;; Q
     77 ;; ;
     78 ;;PUSH(OCXDA) ;
     79 ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB  S OCXDA(OCXSUB+1)=OCXDA(OCXSUB)
     80 ;; S OCXDA(1)=OCXDA,OCXDA=0
     81 ;; Q
     82 ;; ;
     83 ;;POP(OCXDA) ;
     84 ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB  S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1))
     85 ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1))
     86 ;; Q
     87 ;; ;
     88 ;;APPEND(ARRAY,OCXSUB) ;
     89 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
     90 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
     91 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
     92 ;; ;
     93 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
     94 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     95 ;; Q:'$L($G(OCXZ0)) U
     96 ;; S DIR(0)=OCXZ0
     97 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
     98 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
     99 ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
     100 ;; D ^DIR
     101 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     102 ;; Q Y
     103 ;; ;
     104 ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
     105 ;; ;
     106 ;;$
     107 ;1;
     108 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND8.m

    r613 r623  
    1 OCXSEND8        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 4) ;1/31/01  08:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N R,LINE,TEXT,NOW,RUCI
    8         S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
    9         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
    10         ;
    11         M ^TMP("OCXSEND",$J,"RTN")=R
    12         ;
    13         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(4,1)
    14         W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN")
    15         ;
    16         Q " "
    17         ;
    18 TEXT    ;
    19         ;;|$$RNAME^OCXSEND3(4,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    20         ;;|OCXLIN2|
    21         ;;|OCXLIN3|
    22         ;; ;
    23         ;;S ;
    24         ;; ;  Field Utilities
    25         ;; Q
    26         ;; ;
    27         ;;EDITFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ;
    28         ;; ;
    29         ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT
    30         ;; ;
    31         ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1)
    32         ;; S OCXLVL=$L(DDPATH,",")
    33         ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2)
    34         ;; S OCXDA=OCXDA(0) K OCXDA(0)
    35         ;; I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D
    36         ;; .N RESP
    37         ;; .Q:(OCXFLAG["D")
    38         ;; .I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to change the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' field ?","YES") I 'RESP S QUIT=(RESP[U) Q
    39         ;; .S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF)
    40         ;; .D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL-1)
    41         ;; ;
    42         ;; Q QUIT
    43         ;; ;
    44         ;;DELFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ;
    45         ;; ;
    46         ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT,RESP
    47         ;; ;
    48         ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1)
    49         ;; S OCXLVL=$L(DDPATH,",")
    50         ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2)
    51         ;; S OCXDA=OCXDA(0) K OCXDA(0)
    52         ;; Q:(OCXFLAG["D") 0
    53         ;; I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to Delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' value ?","YES") I 'RESP S QUIT=(RESP[U) Q QUIT
    54         ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF)
    55         ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,"@",.OCXDA,OCXLVL-1)
    56         ;; ;
    57         ;; Q QUIT
    58         ;; ;
    59         ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ;
    60         ;; ;
    61         ;; N OCXFLD,OCXGREF
    62         ;; ;
    63         ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF)  S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1
    64         ;; ;
    65         ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U
    66         ;; ;
    67         ;; S OCXFLD=0 F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD  Q:(OCXFLD[":")  I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D
    68         ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL)
    69         ;; ;
    70         ;; D PUSH(.OCXDA)
    71         ;; S OCXFLD="" F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  I (OCXFLD[":") D
    72         ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1)
    73         ;; D POP(.OCXDA)
    74         ;; Q
    75         ;; ;
    76         ;;PUSH(OCXDA) ;
    77         ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB  S OCXDA(OCXSUB+1)=OCXDA(OCXSUB)
    78         ;; S OCXDA(1)=OCXDA,OCXDA=0
    79         ;; Q
    80         ;; ;
    81         ;;POP(OCXDA) ;
    82         ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB  S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1))
    83         ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1))
    84         ;; Q
    85         ;; ;
    86         ;;APPEND(ARRAY,OCXSUB) ;
    87         ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
    88         ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
    89         ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
    90         ;; ;
    91         ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
    92         ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    93         ;; Q:'$L($G(OCXZ0)) U
    94         ;; S DIR(0)=OCXZ0
    95         ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
    96         ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
    97         ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
    98         ;; D ^DIR
    99         ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    100         ;; Q Y
    101         ;; ;
    102         ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
    103         ;; ;
    104         ;;$
    105         ;1;
    106         ;
     1OCXSEND8 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 4) ;1/31/01  08:44
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N R,LINE,TEXT,NOW,RUCI,XCM
     8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND
     9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
     10 ;
     11 M ^TMP("OCXSEND",$J,"RTN")=R
     12 ;
     13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(4,1)
     14 W !,X X ^%ZOSF("SAVE") W "  ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN")
     15 ;
     16 Q XCM
     17 ;
     18TEXT ;
     19 ;;|$$RNAME^OCXSEND3(4,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     20 ;;|OCXLIN2|
     21 ;;|OCXLIN3|
     22 ;; ;
     23 ;;S ;
     24 ;; ;  Field Utilities
     25 ;; Q
     26 ;; ;
     27 ;;EDITFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ;
     28 ;; ;
     29 ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT
     30 ;; ;
     31 ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1)
     32 ;; S OCXLVL=$L(DDPATH,",")
     33 ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2)
     34 ;; S OCXDA=OCXDA(0) K OCXDA(0)
     35 ;; I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D
     36 ;; .N RESP
     37 ;; .Q:(OCXFLAG["D")
     38 ;; .I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to change the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' field ?","YES") I 'RESP S QUIT=(RESP[U) Q
     39 ;; .S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF)
     40 ;; .D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL-1)
     41 ;; ;
     42 ;; Q QUIT
     43 ;; ;
     44 ;;DELFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ;
     45 ;; ;
     46 ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT,RESP
     47 ;; ;
     48 ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1)
     49 ;; S OCXLVL=$L(DDPATH,",")
     50 ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2)
     51 ;; S OCXDA=OCXDA(0) K OCXDA(0)
     52 ;; Q:(OCXFLAG["D") 0
     53 ;; I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to Delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' value ?","YES") I 'RESP S QUIT=(RESP[U) Q QUIT
     54 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF)
     55 ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,"@",.OCXDA,OCXLVL-1)
     56 ;; ;
     57 ;; Q QUIT
     58 ;; ;
     59 ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ;
     60 ;; ;
     61 ;; N OCXFLD,OCXGREF
     62 ;; ;
     63 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF)  S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1
     64 ;; ;
     65 ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U
     66 ;; ;
     67 ;; S OCXFLD=0 F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD  Q:(OCXFLD[":")  I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D
     68 ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL)
     69 ;; ;
     70 ;; D PUSH(.OCXDA)
     71 ;; S OCXFLD="" F  S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD)  I (OCXFLD[":") D
     72 ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1)
     73 ;; D POP(.OCXDA)
     74 ;; Q
     75 ;; ;
     76 ;;PUSH(OCXDA) ;
     77 ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB  S OCXDA(OCXSUB+1)=OCXDA(OCXSUB)
     78 ;; S OCXDA(1)=OCXDA,OCXDA=0
     79 ;; Q
     80 ;; ;
     81 ;;POP(OCXDA) ;
     82 ;; N OCXSUB S OCXSUB="" F  S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB  S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1))
     83 ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1))
     84 ;; Q
     85 ;; ;
     86 ;;APPEND(ARRAY,OCXSUB) ;
     87 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
     88 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
     89 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
     90 ;; ;
     91 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
     92 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     93 ;; Q:'$L($G(OCXZ0)) U
     94 ;; S DIR(0)=OCXZ0
     95 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
     96 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
     97 ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
     98 ;; D ^DIR
     99 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     100 ;; Q Y
     101 ;; ;
     102 ;;PAUSE() W "  Press Enter " R X:DTIME W ! Q (X[U)
     103 ;; ;
     104 ;;$
     105 ;1;
     106 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSENDA.m

    r613 r623  
    1 OCXSENDA        ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Main Routine) ;6/12/02  12:03
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,143,243**;Dec 17,1997;Build 242
    3         ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
    4         ;
    5 EN()    ;
    6         ;
    7         N R,LINE,TEXT,NOW,RUCI
    8         S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND,CVER=$$VERSION^OCXOCMP
    9         F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
    10         ;
    11         M ^TMP("OCXSEND",$J,"RTN")=R
    12         ;
    13         S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,0)
    14         W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN")
    15         ;
    16         Q " "
    17         ;
    18         ;
    19 TEXT    ;
    20         ;;|$$RNAME^OCXSEND3(0,0)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
    21         ;;|OCXLIN2|
    22         ;;|OCXLIN3|
    23         ;; ;
    24         ;;S ;
    25         ;; ;
    26         ;; N OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG S QUIT=0
    27         ;; N OCXAUTO,OCZSCR
    28         ;; ;
    29         ;; D DOT
    30         ;; I $L($T(VERSION^OCXOCMP)),($$VERSION^OCXOCMP="|CVER|"),1
    31         ;; E  D  Q
    32         ;; .W !
    33         ;; .W !,"Rule Transport aborted, version mismatch."
    34         ;; .W !,"Current Local version: ",$$VERSION^OCXOCMP
    35         ;; .W !,"   Rule Transport Version: |CVER|"
    36         ;; I '$D(DTIME) W !!,"DTIME not defined !!",!! Q
    37         ;; W !!,"Order Check Expert System Rule Transporter"
    38         ;; W !," Created: |NOW|  at  |RUCI|"
    39         ;; W !," Current Date: ",$$NOW^|$$RNAME^OCXSEND3(0,1)|,"  at  ",$$NETNAME^OCXSEND,!!
    40         ;; S LASTFILE=0 K ^TMP("OCXRULE",$J)
    41         ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
    42         ;; S OCXFLAG="|OCXASK|"
    43         ;; ;
    44         ;;RUN ;
    45         ;; ;
    46         ;; W !,"Loading Data " D ^|$$RNAME^OCXSEND3(1,2)|
    47         ;; ;
    48         ;; S LINE=0 F  S LINE=$O(^TMP("OCXRULE",$J,LINE)) Q:'LINE   D  Q:QUIT
    49         ;; .D:'(LINE#50) STATUS^OCXOPOST(LINE,$O(^TMP("OCXRULE",$J," "),-1))
    50         ;; .S TEXT=$G(^TMP("OCXRULE",$J,LINE)) I $L(TEXT) D  Q:QUIT
    51         ;; ..S TEXT=$P(TEXT,";",2,999),OPCODE=$P(TEXT,U,1),TEXT=$P(TEXT,U,2,999)
    52         ;; ..;
    53         ;; ..I OPCODE="KEY" D DOT S LOCAL="",D0=$$GETFILE^|$$RNAME^OCXSEND3(0,1)|(+$P(TEXT,U,1),$P(TEXT,U,2),.LOCAL) S QUIT=(D0=(-10)) Q
    54         ;; ..I OPCODE="R" S REF="REMOTE("_$P(TEXT,":",1)_":"_D0_$P(TEXT,":",2,99)_")" Q
    55         ;; ..I OPCODE="D",$D(REF) S @REF=$P(TEXT,U,1,999) K REF Q
    56         ;; ..;
    57         ;; ..I OPCODE="EOR" S QUIT=$$COMPARE^|$$RNAME^OCXSEND3(1,1)|(.LOCAL,.REMOTE) K LOCAL,REMOTE Q
    58         ;; ..I OPCODE="EOF" K LOCAL,REMOTE Q
    59         ;; ..I OPCODE="SOF" W !,"  Installing '",TEXT,"' records... " Q
    60         ;; ..I OPCODE="ROOT" D  Q
    61         ;; ...N FILE,DATA
    62         ;; ...S FILE=U_$P(TEXT,U,1),DATA=$P(TEXT,U,2,3)
    63         ;; ...I ($P($G(@FILE),U,1,2)=DATA) Q
    64         ;; ...S $P(@FILE,U,1,2)=DATA
    65         ;; ...W !,"  Restoring file #",(+$P(DATA,U,2))," zero node"
    66         ;; ..;
    67         ;; ..W !,"Unknown OpCode: ",OPCODE,"  in: ",TEXT S QUIT=$$PAUSE^|$$RNAME^OCXSEND3(0,1)| W !
    68         ;; ;
    69         ;; K ^TMP("OCXRULE",$J)
    70         ;; ;
    71         ;; I $D(^OCXS) D
    72         ;; .N FILE,DO,PD0,CNT
    73         ;; .S FILE=0 F  S FILE=$O(^OCXS(FILE)) Q:'FILE  D
    74         ;; ..S D0=0 F CNT=0:1 S PD0=D0,D0=$O(^OCXS(FILE,D0)) Q:'D0
    75         ;; ..S $P(^OCXS(FILE,0),U,3,4)=CNT_U_PD0
    76         ;; ;
    77         ;; I $G(OCXDIER) D
    78         ;; .W !!!!!!!
    79         ;; .W !,?5,"******************** Warning ******************** "
    80         ;; .W !,?7,+$G(OCXDIER)," data filing error",$S(($G(OCXDIER)=1):"",1:"s"),"."
    81         ;; .W !,?7,"Some expert system rules may be incomplete."
    82         ;; .W !,?5,"******************** Warning ******************** "
    83         ;; I '$G(OCXDIER) W !!,?5," No data filing errors."
    84         ;; W !!,"Transport Finished..."
    85         ;; ;
    86         ;; D
    87         ;; .N OCXOETIM
    88         ;; .D BMES^XPDUTL("---Creating Order Check Routines-----------------------------------")
    89         ;; .D AUTO^OCXOCMP
    90         ;; ;
    91         ;; Q
    92         ;; ;
    93         ;;DOT Q:$G(OCXAUTO)  W:($X>70) ! W " ." Q
    94         ;; ;
    95         ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
    96         ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    97         ;; Q:'$L($G(OCXZ0)) U
    98         ;; S DIR(0)=OCXZ0
    99         ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
    100         ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
    101         ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
    102         ;; D ^DIR
    103         ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
    104         ;; Q Y
    105         ;; ;
    106         ;;$
    107         ;1;
     1OCXSENDA ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Main Routine) ;6/12/02  12:03
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,143**;Dec 17,1997
     3 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
     4 ;
     5EN() ;
     6 ;
     7 N R,LINE,TEXT,NOW,RUCI,XCM
     8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND,CVER=$$VERSION^OCXOCMP
     9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT  S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT)
     10 ;
     11 M ^TMP("OCXSEND",$J,"RTN")=R
     12 ;
     13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,0)
     14 W !,X X ^%ZOSF("SAVE") W "  ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN")
     15 ;
     16 Q XCM
     17 ;
     18 ;
     19TEXT ;
     20 ;;|$$RNAME^OCXSEND3(0,0)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW|
     21 ;;|OCXLIN2|
     22 ;;|OCXLIN3|
     23 ;; ;
     24 ;;S ;
     25 ;; ;
     26 ;; N OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG S QUIT=0
     27 ;; N OCXAUTO,OCZSCR
     28 ;; ;
     29 ;; D DOT
     30 ;; I $L($T(VERSION^OCXOCMP)),($$VERSION^OCXOCMP="|CVER|"),1
     31 ;; E  D  Q
     32 ;; .W !
     33 ;; .W !,"Rule Transport aborted, version mismatch."
     34 ;; .W !,"Current Local version: ",$$VERSION^OCXOCMP
     35 ;; .W !,"   Rule Transport Version: |CVER|"
     36 ;; I '$D(DTIME) W !!,"DTIME not defined !!",!! Q
     37 ;; W !!,"Order Check Expert System Rule Transporter"
     38 ;; W !," Created: |NOW|  at  |RUCI|"
     39 ;; W !," Current Date: ",$$NOW^|$$RNAME^OCXSEND3(0,1)|,"  at  ",$$NETNAME^OCXSEND,!!
     40 ;; S LASTFILE=0 K ^TMP("OCXRULE",$J)
     41 ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG"
     42 ;; S OCXFLAG="|OCXASK|"
     43 ;; ;
     44 ;;RUN ;
     45 ;; ;
     46 ;; W !,"Loading Data " D ^|$$RNAME^OCXSEND3(1,2)|
     47 ;; ;
     48 ;; S LINE=0 F  S LINE=$O(^TMP("OCXRULE",$J,LINE)) Q:'LINE   D  Q:QUIT
     49 ;; .D:'(LINE#50) STATUS^OCXOPOST(LINE,$O(^TMP("OCXRULE",$J," "),-1))
     50 ;; .S TEXT=$G(^TMP("OCXRULE",$J,LINE)) I $L(TEXT) D  Q:QUIT
     51 ;; ..S TEXT=$P(TEXT,";",2,999),OPCODE=$P(TEXT,U,1),TEXT=$P(TEXT,U,2,999)
     52 ;; ..;
     53 ;; ..I OPCODE="KEY" D DOT S LOCAL="",D0=$$GETFILE^|$$RNAME^OCXSEND3(0,1)|(+$P(TEXT,U,1),$P(TEXT,U,2),.LOCAL) S QUIT=(D0=(-10)) Q
     54 ;; ..I OPCODE="R" S REF="REMOTE("_$P(TEXT,":",1)_":"_D0_$P(TEXT,":",2,99)_")" Q
     55 ;; ..I OPCODE="D",$D(REF) S @REF=$P(TEXT,U,1,999) K REF Q
     56 ;; ..;
     57 ;; ..I OPCODE="EOR" S QUIT=$$COMPARE^|$$RNAME^OCXSEND3(1,1)|(.LOCAL,.REMOTE) K LOCAL,REMOTE Q
     58 ;; ..I OPCODE="EOF" K LOCAL,REMOTE Q
     59 ;; ..I OPCODE="SOF" W !,"  Installing '",TEXT,"' records... " Q
     60 ;; ..I OPCODE="ROOT" D  Q
     61 ;; ...N FILE,DATA
     62 ;; ...S FILE=U_$P(TEXT,U,1),DATA=$P(TEXT,U,2,3)
     63 ;; ...I ($P($G(@FILE),U,1,2)=DATA) Q
     64 ;; ...S $P(@FILE,U,1,2)=DATA
     65 ;; ...W !,"  Restoring file #",(+$P(DATA,U,2))," zero node"
     66 ;; ..;
     67 ;; ..W !,"Unknown OpCode: ",OPCODE,"  in: ",TEXT S QUIT=$$PAUSE^|$$RNAME^OCXSEND3(0,1)| W !
     68 ;; ;
     69 ;; K ^TMP("OCXRULE",$J)
     70 ;; ;
     71 ;; I $D(^OCXS) D
     72 ;; .N FILE,DO,PD0,CNT
     73 ;; .S FILE=0 F  S FILE=$O(^OCXS(FILE)) Q:'FILE  D
     74 ;; ..S D0=0 F CNT=0:1 S PD0=D0,D0=$O(^OCXS(FILE,D0)) Q:'D0
     75 ;; ..S $P(^OCXS(FILE,0),U,3,4)=CNT_U_PD0
     76 ;; ;
     77 ;; I $G(OCXDIER) D
     78 ;; .W !!!!!!!
     79 ;; .W !,?5,"******************** Warning ******************** "
     80 ;; .W !,?7,+$G(OCXDIER)," data filing error",$S(($G(OCXDIER)=1):"",1:"s"),"."
     81 ;; .W !,?7,"Some expert system rules may be incomplete."
     82 ;; .W !,?5,"******************** Warning ******************** "
     83 ;; I '$G(OCXDIER) W !!,?5," No data filing errors."
     84 ;; W !!,"Transport Finished..."
     85 ;; ;
     86 ;; D
     87 ;; .N OCXOETIM
     88 ;; .D BMES^XPDUTL("---Creating Order Check Routines-----------------------------------")
     89 ;; .D AUTO^OCXOCMP
     90 ;; ;
     91 ;; Q
     92 ;; ;
     93 ;;DOT Q:$G(OCXAUTO)  W:($X>70) ! W " ." Q
     94 ;; ;
     95 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
     96 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
     97 ;; Q:'$L($G(OCXZ0)) U
     98 ;; S DIR(0)=OCXZ0
     99 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
     100 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
     101 ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
     102 ;; D ^DIR
     103 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
     104 ;; Q Y
     105 ;; ;
     106 ;;$
     107 ;1;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP1.m

    r613 r623  
    1 ORB3FUP1        ; slc/CLA - Routine to support notification follow-up actions ; 4/8/08 9:32am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,64,74,105,139,243**;Dec 17, 1997;Build 242
    3         Q
    4 TYPE(ORBY,ORXQAID)      ; return notif follow-up action type
    5         N NIEN
    6         S NIEN=$P($P(ORXQAID,";"),",",3)
    7         S ORBY=$G(^ORD(100.9,NIEN,3))
    8         I ORBY="" S ORBY="INFO^"
    9         E  S ORBY=$P(ORBY,U,2)
    10         Q
    11 GUI(ORBY,ORXQAID)       ; Notification follow-up for GUI called via API: ORB FOLLOW-UP
    12         ; called by ORB FOLLOW-UP api:
    13         S ORENVIR="GUI"
    14         D PROCESS
    15         Q
    16 PROCESS ; main process for notification follow-up
    17         ;ORXQAID = OR,dfn,nien;
    18         ;XQADATA = placer num^placer id;filler num^filler id
    19         ;XQAKILL = value of parameter ORB DELETE MECHANISM for notif in 100.9
    20         N ORPDIEN,ORN,ORDFN,ORSITE,ORFID,ORFIEN,ORKILL
    21         D GETACT^XQALERT(ORXQAID)  ;return follow-up action info
    22         ;Q:'($D(XQADATA))  Q:'($D(XQAID))
    23         ;Q:($P(XQAID,",")'="OR")
    24         ;call function rpc stored in xqarou with params from xqadata
    25         D @XQAROU
    26         K ORENVIR
    27         Q
    28 MSG     ; display msg re: alert being processed for non-GUI follow-up actions
    29         I $G(ORENVIR)'="GUI" D
    30         .I $L($G(XQX)) W !!,"Processing alert: ",$P(XQX,U,3) H 1.5
    31         Q
    32 DEL(ORBY,XQAID,ORKILL)  ; delete an alert
    33         N ORN
    34         S ORN=$P($P(XQAID,";"),",",3)
    35         I $G(ORKILL)=1!($G(ORKILL)=0) S XQAKILL=ORKILL
    36         I $G(XQAKILL)="" S XQAKILL=$$XQAKILL^ORB3F1(ORN)
    37         I $G(XQAKILL)="" S XQAKILL=1
    38         S ORBY="FALSE"
    39         I $L($G(XQAID)) D DELETE^XQALERT S ORBY="TRUE"
    40         K XQAKILL
    41         Q
    42 CSORD   ;co-sign order(s) follow-up
    43         K XQAKILL
    44         N ORPT,ORDG,ORBXQAID,ORY S ORBXQAID=XQAID
    45         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    46         ;the FLG code for orders requiring CO-SIGNATURE in ORQ1 is 'to be determined when ASU is available'
    47         D DEL(.ORY,XQAID)  ;until ASU is implemented, delete the alert and quit
    48         Q  ;quit until ASU is implemented
    49         ;I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",???,"","")
    50         ;I $G(ORENVIR)'="GUI" D
    51         ;.D MSG
    52         ;.S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    53         ;.D EN^ORCB(ORPT,???,ORDG,???)
    54         ;.K ^TMP("ORR",$J)
    55         ;.D EN^ORQ1(ORPT_";DPT(",ORDG,???,"","","",0,0)
    56         ;.S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    57         ;..D DEL(.ORY,ORBXQAID)  ;if no more orders req. co-sign, delete the alert
    58         ;.K ^TMP("ORR",$J)
    59         Q
    60 EXDNR   ;expiring dnr follow-up
    61         K XQAKILL
    62         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    63         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    64         N DNRORD,DNRY S DNRORD=$P(XQADATA,"@")
    65         I $G(ORENVIR)="GUI" D
    66         .S ORBY(1)=DNRY
    67         I $G(ORENVIR)'="GUI" D
    68         .D MSG
    69         .D EN1^ORCB(DNRORD,"RENEW")  ;display order, allow renewing, then delete
    70         .D DEL(.ORY,ORBXQAID)
    71         Q
    72 UNLINKED        ;unlinked provider follow-up
    73         K XQAKILL
    74         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    75         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    76         N ORNUM,ORUNY S ORNUM=$P(XQADATA,"@")
    77         I $G(ORENVIR)="GUI" D
    78         .S ORBY(1)=ORUNY
    79         I $G(ORENVIR)'="GUI" D
    80         .D MSG
    81         .D EN1^ORCB(ORNUM,"REPLACE")  ;display order, allow replace, then delete
    82         .D DEL(.ORY,ORBXQAID)
    83         Q
    84 FLORD   ;flagged order(s) follow-up
    85         K XQAKILL
    86         N ORPT,ORDG,X,ORBXQAID,ORY,ORBLMDEL
    87         S ORBXQAID=XQAID
    88         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    89         ;the FLG code for "FLAGGED" in ORQ1 is '12'
    90         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",12,"","")
    91         I $G(ORENVIR)'="GUI" D
    92         .D MSG
    93         .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    94         .D EN^ORCB(ORPT,12,ORDG,.ORBLMDEL)
    95         .K ^TMP("ORR",$J)
    96         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    97         .D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0)
    98         .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    99         ..D DEL(.ORY,ORBXQAID)  ;if no more flagged orders found, delete alert
    100         .K ^TMP("ORR",$J)
    101         Q
    102 NEWORD  ;new order(s) follow-up
    103         K XQAKILL
    104         N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL
    105         S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID
    106         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    107         ;the FLG code for NEW orders since last reviewed orders in ORQ1 is '6'
    108         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","")
    109         I $G(ORENVIR)'="GUI" D
    110         .D MSG
    111         .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    112         .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL)
    113         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    114         .D DEL(.ORY,ORBXQAID) ;delete the alert
    115         Q
    116 DCORD   ;DC order(s) follow-up
    117         K XQAKILL
    118         N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL
    119         S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID
    120         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    121         ;the FLG code for DC orders is '3'
    122         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","")
    123         I $G(ORENVIR)'="GUI" D
    124         .D MSG
    125         .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    126         .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL)
    127         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    128         .D DEL(.ORY,ORBXQAID) ;delete the alert
    129         Q
    130 NUMORD  ;detailed order display follow-up - return order number
    131         K XQAKILL
    132         N ORBXQAID,ORY S ORBXQAID=XQAID
    133         S ORNUM=$P(XQADATA,"@")
    134         I $G(ORENVIR)="GUI" D
    135         .Q
    136         I $G(ORENVIR)'="GUI" D
    137         .D MSG
    138         .D EN1^ORCB(+ORNUM,"NEW")  ;display order, allow new order then delete
    139         .D DEL(.ORY,ORBXQAID)
    140         Q
    141 ESORD   ;order(s) requiring electronic signature follow-up
    142         K XQAKILL
    143         N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL
    144         S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0
    145         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    146         ;the FLG code for UNSIGNED orders in ORQ1 is '11'
    147         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",11,"","")
    148         I $G(ORENVIR)'="GUI" D
    149         .D MSG
    150         .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    151         .D EN^ORCB(ORPT,11,ORDG,.ORBLMDEL)
    152         .K ^TMP("ORR",$J)  ;clean up array
    153         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    154         .I $L($G(XQAID)) D  ;EN^ORCB may kill XQAID in its follow-up
    155         ..;
    156         ..;get unsigned orders - if none exist, delete alert then quit:
    157         ..D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0)
    158         ..S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""  I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
    159         ..;
    160         ..;user does not have ORES key, delete user's alert:
    161         ..I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
    162         ..;
    163         ..;if prov is NOT linked to pt via attending, primary, teams or PCMM:
    164         ..I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D
    165         ...S ORX="" F  S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1)  D
    166         ....S ORZ="" F  S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:ORZ=""!(ORDERS=1)  D
    167         .....S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
    168         .....;quit if this unsigned order's last action was made by the user
    169         .....I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1
    170         ...I ORDERS'=1 D  ;provider has no outstanding unsiged orders for pt
    171         ....S XQAKILL=1 D DEL(.ORY,ORBXQAID) ;delete alert for this user
    172         ..K ^TMP("ORR",$J)
    173         Q
    174 UNFLAG(ORPT)    ;order unflagged - delete alert if no more flagged orders
    175         N ORDG,ORDOIT,ORQUIT,X,XQAID,XQAKILL,XQAUSER
    176         S ORDOIT=1,ORQUIT=0
    177         S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    178         K ^TMP("ORR",$J)
    179         D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0)
    180         ;========DELETE ALERT (FOR ALL USERS) IF NO FLAGGED ORDERS AT ALL=====
    181         S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    182         .;if no more flagged orders found, delete alert:
    183         .S XQAKILL=$$XQAKILL^ORB3F1(6)
    184         .I $G(XQAKILL)="" S XQAKILL=1
    185         .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL S ORQUIT=1
    186         Q:ORQUIT
    187         ;========DELETE ALERT IF NO FLAGGED ORDERS LEFT RELATED TO THE USER THAT IS UNFLAGGING=====
    188         S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  D
    189         .N Y S Y="" F  S Y=$O(^TMP("ORR",$J,X,Y)) Q:'Y  D
    190         ..N ORDER S ORDER=$G(^TMP("ORR",$J,X,Y))
    191         ..I $$FLAGRULE^ORWORR1(+ORDER)=0 S ORDOIT=0 ; FOUND A FLAGGED ORDER THAT THE USER SHOULD GET
    192         I ORDOIT D
    193         .;if no more flagged orders found for this user, delete alert only for this user:
    194         .S XQAKILL=1
    195         .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL
    196         ;========DELETE ALERT IF NO FLAGGED ORDERS LEFT RELATED TO THE USER THAT WAS THE ALERTED PROVIDER OF THE CURRENT ORDER=====
    197         S ORDOIT=1
    198         ;get the alerted provider
    199         I $G(ORIFN) D
    200         .N ORD,ORACT S ORD=+$G(ORIFN),ORACT=$P($G(ORIFN),";",2)
    201         .N ORUSR S ORUSR=$P($G(^OR(100,ORD,8,ORACT,3)),U,9)
    202         .I ORUSR D
    203         ..S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  D
    204         ...N Y S Y="" F  S Y=$O(^TMP("ORR",$J,X,Y)) Q:'Y  D
    205         ....N ORDER S ORDER=$G(^TMP("ORR",$J,X,Y))
    206         ....I $$FLAGRULE^ORWORR1(+ORDER,ORUSR)=0 S ORDOIT=0 ; FOUND A FLAGGED ORDER THAT THE USER SHOULD GET
    207         ..I ORDOIT D
    208         ...;if no more flagged orders found for this user, delete alert only for this user:
    209         ...S XQAKILL=1,XQAUSER=ORUSR
    210         ...S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL,XQAUSER
    211         K ^TMP("ORR",$J)
    212         Q
     1ORB3FUP1 ; slc/CLA - Routine to support notification follow-up actions ;7/15/95  17:23
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,64,74,105,139**;Dec 17, 1997
     3 Q
     4TYPE(ORBY,ORXQAID) ; return notif follow-up action type
     5 N NIEN
     6 S NIEN=$P($P(ORXQAID,";"),",",3)
     7 S ORBY=$G(^ORD(100.9,NIEN,3))
     8 I ORBY="" S ORBY="INFO^"
     9 E  S ORBY=$P(ORBY,U,2)
     10 Q
     11GUI(ORBY,ORXQAID) ; Notification follow-up for GUI called via API: ORB FOLLOW-UP
     12 ; called by ORB FOLLOW-UP api:
     13 S ORENVIR="GUI"
     14 D PROCESS
     15 Q
     16PROCESS ; main process for notification follow-up
     17 ;ORXQAID = OR,dfn,nien;
     18 ;XQADATA = placer num^placer id;filler num^filler id
     19 ;XQAKILL = value of parameter ORB DELETE MECHANISM for notif in 101.9
     20 N ORPDIEN,ORN,ORDFN,ORSITE,ORFID,ORFIEN,ORKILL
     21 D GETACT^XQALERT(ORXQAID)  ;return follow-up action info
     22 ;Q:'($D(XQADATA))  Q:'($D(XQAID))
     23 ;Q:($P(XQAID,",")'="OR")
     24 ;call function rpc stored in xqarou with params from xqadata
     25 D @XQAROU
     26 K ORENVIR
     27 Q
     28MSG ; display msg re: alert being processed for non-GUI follow-up actions
     29 I $G(ORENVIR)'="GUI" D
     30 .I $L($G(XQX)) W !!,"Processing alert: ",$P(XQX,U,3) H 1.5
     31 Q
     32DEL(ORBY,XQAID,ORKILL) ; delete an alert
     33 N ORN
     34 S ORN=$P($P(XQAID,";"),",",3)
     35 I $G(ORKILL)=1!($G(ORKILL)=0) S XQAKILL=ORKILL
     36 I $G(XQAKILL)="" S XQAKILL=$$XQAKILL^ORB3F1(ORN)
     37 I $G(XQAKILL)="" S XQAKILL=1
     38 S ORBY="FALSE"
     39 I $L($G(XQAID)) D DELETE^XQALERT S ORBY="TRUE"
     40 K XQAKILL
     41 Q
     42CSORD ;co-sign order(s) follow-up
     43 K XQAKILL
     44 N ORPT,ORDG,ORBXQAID,ORY S ORBXQAID=XQAID
     45 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     46 ;the FLG code for orders requiring CO-SIGNATURE in ORQ1 is 'to be determined when ASU is available'
     47 D DEL(.ORY,XQAID)  ;until ASU is implemented, delete the alert and quit
     48 Q  ;quit until ASU is implemented
     49 ;I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",???,"","")
     50 ;I $G(ORENVIR)'="GUI" D
     51 ;.D MSG
     52 ;.S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     53 ;.D EN^ORCB(ORPT,???,ORDG,???)
     54 ;.K ^TMP("ORR",$J)
     55 ;.D EN^ORQ1(ORPT_";DPT(",ORDG,???,"","","",0,0)
     56 ;.S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     57 ;..D DEL(.ORY,ORBXQAID)  ;if no more orders req. co-sign, delete the alert
     58 ;.K ^TMP("ORR",$J)
     59 Q
     60EXDNR ;expiring dnr follow-up
     61 K XQAKILL
     62 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     63 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     64 N DNRORD,DNRY S DNRORD=$P(XQADATA,"@")
     65 I $G(ORENVIR)="GUI" D
     66 .S ORBY(1)=DNRY
     67 I $G(ORENVIR)'="GUI" D
     68 .D MSG
     69 .D EN1^ORCB(DNRORD,"RENEW")  ;display order, allow renewing, then delete
     70 .D DEL(.ORY,ORBXQAID)
     71 Q
     72UNLINKED ;unlinked provider follow-up
     73 K XQAKILL
     74 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     75 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     76 N ORNUM,ORUNY S ORNUM=$P(XQADATA,"@")
     77 I $G(ORENVIR)="GUI" D
     78 .S ORBY(1)=ORUNY
     79 I $G(ORENVIR)'="GUI" D
     80 .D MSG
     81 .D EN1^ORCB(ORNUM,"REPLACE")  ;display order, allow replace, then delete
     82 .D DEL(.ORY,ORBXQAID)
     83 Q
     84FLORD ;flagged order(s) follow-up
     85 K XQAKILL
     86 N ORPT,ORDG,X,ORBXQAID,ORY,ORBLMDEL
     87 S ORBXQAID=XQAID
     88 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     89 ;the FLG code for "FLAGGED" in ORQ1 is '12'
     90 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",12,"","")
     91 I $G(ORENVIR)'="GUI" D
     92 .D MSG
     93 .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     94 .D EN^ORCB(ORPT,12,ORDG,.ORBLMDEL)
     95 .K ^TMP("ORR",$J)
     96 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     97 .D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0)
     98 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     99 ..D DEL(.ORY,ORBXQAID)  ;if no more flagged orders found, delete alert
     100 .K ^TMP("ORR",$J)
     101 Q
     102NEWORD ;new order(s) follow-up
     103 K XQAKILL
     104 N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL
     105 S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID
     106 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     107 ;the FLG code for NEW orders since last reviewed orders in ORQ1 is '6'
     108 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","")
     109 I $G(ORENVIR)'="GUI" D
     110 .D MSG
     111 .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     112 .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL)
     113 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     114 .D DEL(.ORY,ORBXQAID) ;delete the alert
     115 Q
     116DCORD ;DC order(s) follow-up
     117 K XQAKILL
     118 N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL
     119 S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID
     120 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     121 ;the FLG code for DC orders is '3'
     122 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","")
     123 I $G(ORENVIR)'="GUI" D
     124 .D MSG
     125 .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     126 .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL)
     127 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     128 .D DEL(.ORY,ORBXQAID) ;delete the alert
     129 Q
     130NUMORD ;detailed order display follow-up - return order number
     131 K XQAKILL
     132 N ORBXQAID,ORY S ORBXQAID=XQAID
     133 S ORNUM=$P(XQADATA,"@")
     134 I $G(ORENVIR)="GUI" D
     135 .Q
     136 I $G(ORENVIR)'="GUI" D
     137 .D MSG
     138 .D EN1^ORCB(+ORNUM,"NEW")  ;display order, allow new order then delete
     139 .D DEL(.ORY,ORBXQAID)
     140 Q
     141ESORD ;order(s) requiring electronic signature follow-up
     142 K XQAKILL
     143 N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL
     144 S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0
     145 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     146 ;the FLG code for UNSIGNED orders in ORQ1 is '11'
     147 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",11,"","")
     148 I $G(ORENVIR)'="GUI" D
     149 .D MSG
     150 .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     151 .D EN^ORCB(ORPT,11,ORDG,.ORBLMDEL)
     152 .K ^TMP("ORR",$J)  ;clean up array
     153 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     154 .I $L($G(XQAID)) D  ;EN^ORCB may kill XQAID in its follow-up
     155 ..;
     156 ..;get unsigned orders - if none exist, delete alert then quit:
     157 ..D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0)
     158 ..S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""  I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
     159 ..;
     160 ..;user does not have ORES key, delete user's alert:
     161 ..I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
     162 ..;
     163 ..;if prov is NOT linked to pt via attending, primary, teams or PCMM:
     164 ..I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D
     165 ...S ORX="" F  S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1)  D
     166 ....S ORZ="" F  S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:ORZ=""!(ORDERS=1)  D
     167 .....S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
     168 .....;quit if this unsigned order's last action was made by the user
     169 .....I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1
     170 ...I ORDERS'=1 D  ;provider has no outstanding unsiged orders for pt
     171 ....S XQAKILL=1 D DEL(.ORY,ORBXQAID) ;delete alert for this user
     172 ..K ^TMP("ORR",$J)
     173 Q
     174UNFLAG(ORPT) ;order unflagged - delete alert if no more flagged orders
     175 N ORDG
     176 S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     177 K ^TMP("ORR",$J)
     178 D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0)
     179 S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     180 .;if no more flagged orders found, delete alert:
     181 .S XQAKILL=$$XQAKILL^ORB3F1(6)
     182 .I $G(XQAKILL)="" S XQAKILL=1
     183 .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL
     184 K ^TMP("ORR",$J)
     185 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP2.m

    r613 r623  
    1 ORB3FUP2        ; slc/CLA - Routine to support notification follow-up actions ;6/28/00  12:00
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,64,88,112,243**;Dec 17, 1997;Build 242
    3 RESULT  ;STAT, orderer-flagged and site-flagged result follow-up
    4         ;determine what pkg to get report/results from then do RPTLAB or RPTRAD
    5         N ORBFILL S ORBFILL=$P($P(XQADATA,"|",2),"@",2)
    6         I ORBFILL["LR" D RPTLAB
    7         I ORBFILL["RA" D RPTRAD
    8         I ORBFILL["GMRC" D RPTCON
    9         Q
    10 CSPN    ;co-sign progress note(s) follow-up
    11         K XQAKILL
    12         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    13         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    14         I $G(ORENVIR)="GUI" ;entry pt to get notes req co-sign then quit
    15         ;joel rtn to display notes req co-signature and allow co-sign on vt
    16         ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID)
    17         Q
    18 USPN    ;unsigned progress note(s) follow-up
    19         K XQAKILL
    20         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    21         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    22         I $G(ORENVIR)="GUI" ;entry pt to get unsigned notes then quit
    23         ;joel rtn to display notes req signature and allow signature on vt
    24         ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID)
    25         Q
    26 EXMED   ;expiring med(s) follow-up
    27         K XQAKILL
    28         N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL
    29         S ORBXQAID=XQAID
    30         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    31         ;the FLG code for EXPIRING orders in ORQ1 is '5'
    32         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",5,"","")
    33         I $G(ORENVIR)'="GUI" D
    34         .D MSG^ORB3FUP1
    35         .S ORDG=$$DG^ORQOR1("RX")  ;get Display Group ien
    36         .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL)
    37         .K ^TMP("ORR",$J)
    38         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    39         .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0)
    40         .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    41         ..D DEL^ORB3FUP1(.ORY,ORBXQAID)  ;if no more EXPIRING orders found, delete the alert
    42         .K X,^TMP("ORR",$J)
    43         Q
    44 UVMED   ;unverified med(s) follow-up
    45         K XQAKILL
    46         N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT
    47         S ORBXQAID=XQAID
    48         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    49         ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9'
    50         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",9,"","")
    51         I $G(ORENVIR)'="GUI" D
    52         .D MSG^ORB3FUP1
    53         .S ORDG=$$DG^ORQOR1("RX")  ;get Display Group ien
    54         .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL)
    55         .K ^TMP("ORR",$J)
    56         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    57         .;
    58         .;if user doesn't have ORELSE or ORMAS keys (can't verify),
    59         .;   delete user's alert after display:
    60         .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q
    61         .;
    62         .;get current admission date/time:
    63         .N DFN S DFN=ORPT,VA200="" D INP^VADPT
    64         .S ORADT=$P($G(VAIN(7)),U)
    65         .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT)
    66         .;
    67         .;if no more UNVERIFIED MED orders found (within current admission or
    68         .; past 30 days), delete the alert:
    69         .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0)
    70         .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    71         ..D DEL^ORB3FUP1(.ORY,ORBXQAID)
    72         .K X,^TMP("ORR",$J),VA200,VAIN
    73         Q
    74 UNVER   ;unverified order(s) follow-up
    75         K XQAKILL
    76         N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT
    77         S ORBXQAID=XQAID
    78         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    79         ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9'
    80         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",9,"","")
    81         I $G(ORENVIR)'="GUI" D
    82         .D MSG^ORB3FUP1
    83         .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    84         .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL)
    85         .K ^TMP("ORR",$J)
    86         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    87         .;
    88         .;if user doesn't have ORELSE or ORMAS keys (can't verify),
    89         .;   delete user's alert after display:
    90         .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q
    91         .;
    92         .;get current admission date/time:
    93         .N DFN S DFN=ORPT,VA200="" D INP^VADPT
    94         .S ORADT=$P($G(VAIN(7)),U)
    95         .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT)
    96         .;
    97         .;if no more UNVERIFIED orders found (within current admission or past
    98         .; 30 days), delete the alert:
    99         .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0)
    100         .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    101         ..D DEL^ORB3FUP1(.ORY,ORBXQAID)
    102         .K X,^TMP("ORR",$J),VA200,VAIN
    103         Q
    104 NEWCON  ;new consult/request follow-up
    105         K XQAKILL
    106         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    107         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    108         ;I $G(ORENVIR)="GUI" D  ;comment out until GUI follow-up
    109         ;.entry pt to get new consults then quit
    110         I $G(ORENVIR)'="GUI" D
    111         .D MSG^ORB3FUP1
    112         .D EN^GMRCALRT(XQADATA,XQAID) ;display new c/r and allow action
    113         .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC
    114         Q
    115 UPCON   ;updated consult/request follow-up
    116         K XQAKILL
    117         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    118         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    119         I $G(ORENVIR)'="GUI" D
    120         .D MSG^ORB3FUP1
    121         .D EN^GMRCALRT(XQADATA,XQAID) ;display updated c/r and allow action
    122         Q
    123 DCCON   ;cancelled, held or DCed consult/request follow-up
    124         K XQAKILL
    125         N ORPT,NXQADATA
    126         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    127         ;I $G(ORENVIR)="GUI" D  ;comment out until GUI follow-up
    128         ;.entry pt to get new consults then quit
    129         I $G(ORENVIR)'="GUI" D
    130         .D MSG^ORB3FUP1
    131         .I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCEDIT(NXQADATA,XQAID)
    132         .I +$G(NXQADATA)<1 D EN^GMRCEDIT(XQADATA,XQAID)
    133         Q
    134 RPTCON  ;consult result follow-up
    135         K XQAKILL
    136         N NXQADATA
    137         ;N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    138         ;S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    139         I $G(ORENVIR)="GUI" D DETAIL^ORQQCN(.ORBY,XQADATA)
    140         I $G(ORENVIR)'="GUI" D
    141         .D MSG^ORB3FUP1
    142         .D EN^GMRCALRT(XQADATA,XQAID)
    143         .;I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCALRT(NXQADATA,XQAID)
    144         .;I +$G(NXQADATA)<1 D EN^GMRCALRT(XQADATA,XQAID)
    145         .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC
    146         Q
    147 RPTAP   ; AP lab result follow-up
    148         K XQAKILL
    149         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    150         S ORPT=$P($P(ORBXQAID,";"),",",2)  ;get pt dfn from xqaid
    151         N ORACCNUM,ORDTSTKN S ORACCNUM=$P(XQADATA,U,2),ORDTSTKN=$P(XQADATA,U,3)
    152         I $G(ORENVIR)'="GUI" D
    153         .D MSG^ORB3FUP1
    154         .D EN1^ORCXPND(ORPT,ORACCNUM_"-"_ORDTSTKN,"LABS")
    155         .D DEL^ORB3FUP1(.ORY,ORBXQAID)
    156         Q
    157 RPTLAB  ;lab result follow-up
    158         K XQAKILL
    159         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    160         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    161         N ORDER,ORLAB S ORDER=$P(XQADATA,"@")
    162         I $G(ORENVIR)="GUI" D DETAIL^ORQQLR(.ORBY,ORPT,ORDER)
    163         I $G(ORENVIR)'="GUI" D
    164         .D MSG^ORB3FUP1
    165         .;S ORLAB=$$OETOLAB^ORQQLR1(ORDER)
    166         .;Q:'$L($G(ORLAB))
    167         .;D EN1^ORCXPND(ORPT,ORLAB,"LABS")  ;api used lab # pre-6/97
    168         .D EN1^ORCXPND(ORPT,ORDER,"LABS")
    169         .D DEL^ORB3FUP1(.ORY,ORBXQAID)
    170         Q
    171 RPTRAD  ;radiology result follow-up for HL7-triggered notifications
    172         K XQAKILL
    173         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    174         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    175         N INVDT,CASE S INVDT="",CASE=""
    176         ;XQADATA is different for HL7-triggered vs. radiology pkg triggered
    177         S INVDT=$P(XQADATA,"~",2),CASE=$P($P(XQADATA,"~",3),"@")
    178         I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE)
    179         I $G(ORENVIR)'="GUI" D
    180         .D MSG^ORB3FUP1
    181         .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS")
    182         .D DEL^ORB3FUP1(.ORY,ORBXQAID)
    183         Q
    184 RPTRAD2 ;radiology result follow-up for radiology pkg-triggered notifications
    185         K XQAKILL
    186         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    187         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    188         N INVDT,CASE S INVDT="",CASE=""
    189         ;XQADATA is different for HL7-triggered vs. radiology pkg triggered
    190         S INVDT=$P(XQADATA,"~",1),CASE=$P(XQADATA,"~",2)
    191         I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE)
    192         I $G(ORENVIR)'="GUI" D
    193         .D MSG^ORB3FUP1
    194         .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS")
    195         .D DEL^ORB3FUP1(.ORY,ORBXQAID)
    196         Q
    197 EXOI    ;expiring flagged orderable items follow-up
    198         K XQAKILL
    199         N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL
    200         S ORBXQAID=XQAID
    201         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    202         ;the FLG code for EXPIRING orders in ORQ1 is '5'
    203         I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",5,"","")
    204         I $G(ORENVIR)'="GUI" D
    205         .D MSG^ORB3FUP1
    206         .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    207         .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL)
    208         .K ^TMP("ORR",$J)
    209         .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
    210         .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0)
    211         .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
    212         ..D DEL^ORB3FUP1(.ORY,ORBXQAID)  ;if no more EXPIRING orders found, delete the alert
    213         .K X,^TMP("ORR",$J)
    214         Q
    215 INTCON  ;consult interpretation follow-up
    216         K XQAKILL
    217         N NXQADATA
    218         I $G(ORENVIR)'="GUI" D
    219         .D MSG^ORB3FUP1
    220         .R !!?5,"This alert must be processed in the CPRS GUI.",X:10
    221         .K X
    222         Q
    223 CHGRAD  ;radiology follow-up for #67 Imaging Request Changed
    224         K XQAKILL
    225         N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
    226         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    227         I $G(ORENVIR)'="GUI" D
    228         .D MSG^ORB3FUP1
    229         .I $L($T(EN1^RAO7PC4))>0 D
    230         ..D EN1^RAO7PC4  ;display before and after change(s)
    231         ..D DEL^ORB3FUP1(.ORY,ORBXQAID)
    232         Q
    233 INFODEL ;follow-up action to delete "informational" alerts
    234         K XQAKILL
    235         N ORY,ORBXQAID
    236         S ORBXQAID=XQAID
    237         D MSG^ORB3FUP1
    238         D DEL^ORB3FUP1(.ORY,ORBXQAID)
    239         Q
     1ORB3FUP2 ; slc/CLA - Routine to support notification follow-up actions ;6/28/00  12:00
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,64,88,112**;Dec 17, 1997
     3RESULT ;STAT, orderer-flagged and site-flagged result follow-up
     4 ;determine what pkg to get report/results from then do RPTLAB or RPTRAD
     5 N ORBFILL S ORBFILL=$P($P(XQADATA,"|",2),"@",2)
     6 I ORBFILL["LR" D RPTLAB
     7 I ORBFILL["RA" D RPTRAD
     8 I ORBFILL["GMRC" D RPTCON
     9 Q
     10CSPN ;co-sign progress note(s) follow-up
     11 K XQAKILL
     12 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     13 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     14 I $G(ORENVIR)="GUI" ;entry pt to get notes req co-sign then quit
     15 ;joel rtn to display notes req co-signature and allow co-sign on vt
     16 ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID)
     17 Q
     18USPN ;unsigned progress note(s) follow-up
     19 K XQAKILL
     20 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     21 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     22 I $G(ORENVIR)="GUI" ;entry pt to get unsigned notes then quit
     23 ;joel rtn to display notes req signature and allow signature on vt
     24 ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID)
     25 Q
     26EXMED ;expiring med(s) follow-up
     27 K XQAKILL
     28 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL
     29 S ORBXQAID=XQAID
     30 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     31 ;the FLG code for EXPIRING orders in ORQ1 is '5'
     32 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",5,"","")
     33 I $G(ORENVIR)'="GUI" D
     34 .D MSG^ORB3FUP1
     35 .S ORDG=$$DG^ORQOR1("RX")  ;get Display Group ien
     36 .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL)
     37 .K ^TMP("ORR",$J)
     38 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     39 .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0)
     40 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     41 ..D DEL^ORB3FUP1(.ORY,ORBXQAID)  ;if no more EXPIRING orders found, delete the alert
     42 .K X,^TMP("ORR",$J)
     43 Q
     44UVMED ;unverified med(s) follow-up
     45 K XQAKILL
     46 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT
     47 S ORBXQAID=XQAID
     48 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     49 ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9'
     50 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",9,"","")
     51 I $G(ORENVIR)'="GUI" D
     52 .D MSG^ORB3FUP1
     53 .S ORDG=$$DG^ORQOR1("RX")  ;get Display Group ien
     54 .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL)
     55 .K ^TMP("ORR",$J)
     56 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     57 .;
     58 .;if user doesn't have ORELSE or ORMAS keys (can't verify),
     59 .;   delete user's alert after display:
     60 .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q
     61 .;
     62 .;get current admission date/time:
     63 .N DFN S DFN=ORPT,VA200="" D INP^VADPT
     64 .S ORADT=$P($G(VAIN(7)),U)
     65 .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT)
     66 .;
     67 .;if no more UNVERIFIED MED orders found (within current admission or
     68 .; past 30 days), delete the alert:
     69 .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0)
     70 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     71 ..D DEL^ORB3FUP1(.ORY,ORBXQAID)
     72 .K X,^TMP("ORR",$J),VA200,VAIN
     73 Q
     74UNVER ;unverified order(s) follow-up
     75 K XQAKILL
     76 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT
     77 S ORBXQAID=XQAID
     78 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     79 ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9'
     80 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",9,"","")
     81 I $G(ORENVIR)'="GUI" D
     82 .D MSG^ORB3FUP1
     83 .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     84 .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL)
     85 .K ^TMP("ORR",$J)
     86 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     87 .;
     88 .;if user doesn't have ORELSE or ORMAS keys (can't verify),
     89 .;   delete user's alert after display:
     90 .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q
     91 .;
     92 .;get current admission date/time:
     93 .N DFN S DFN=ORPT,VA200="" D INP^VADPT
     94 .S ORADT=$P($G(VAIN(7)),U)
     95 .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT)
     96 .;
     97 .;if no more UNVERIFIED orders found (within current admission or past
     98 .; 30 days), delete the alert:
     99 .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0)
     100 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     101 ..D DEL^ORB3FUP1(.ORY,ORBXQAID)
     102 .K X,^TMP("ORR",$J),VA200,VAIN
     103 Q
     104NEWCON ;new consult/request follow-up
     105 K XQAKILL
     106 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     107 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     108 ;I $G(ORENVIR)="GUI" D  ;comment out until GUI follow-up
     109 ;.entry pt to get new consults then quit
     110 I $G(ORENVIR)'="GUI" D
     111 .D MSG^ORB3FUP1
     112 .D EN^GMRCALRT(XQADATA,XQAID) ;display new c/r and allow action
     113 .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC
     114 Q
     115UPCON ;updated consult/request follow-up
     116 K XQAKILL
     117 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     118 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     119 I $G(ORENVIR)'="GUI" D
     120 .D MSG^ORB3FUP1
     121 .D EN^GMRCALRT(XQADATA,XQAID) ;display updated c/r and allow action
     122 Q
     123DCCON ;cancelled, held or DCed consult/request follow-up
     124 K XQAKILL
     125 N ORPT,NXQADATA
     126 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     127 ;I $G(ORENVIR)="GUI" D  ;comment out until GUI follow-up
     128 ;.entry pt to get new consults then quit
     129 I $G(ORENVIR)'="GUI" D
     130 .D MSG^ORB3FUP1
     131 .I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCEDIT(NXQADATA,XQAID)
     132 .I +$G(NXQADATA)<1 D EN^GMRCEDIT(XQADATA,XQAID)
     133 Q
     134RPTCON ;consult result follow-up
     135 K XQAKILL
     136 N NXQADATA
     137 ;N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     138 ;S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     139 I $G(ORENVIR)="GUI" D DETAIL^ORQQCN(.ORBY,XQADATA)
     140 I $G(ORENVIR)'="GUI" D
     141 .D MSG^ORB3FUP1
     142 .D EN^GMRCALRT(XQADATA,XQAID)
     143 .;I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCALRT(NXQADATA,XQAID)
     144 .;I +$G(NXQADATA)<1 D EN^GMRCALRT(XQADATA,XQAID)
     145 .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC
     146 Q
     147RPTLAB ;lab result follow-up
     148 K XQAKILL
     149 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     150 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     151 N ORDER,ORLAB S ORDER=$P(XQADATA,"@")
     152 I $G(ORENVIR)="GUI" D DETAIL^ORQQLR(.ORBY,ORPT,ORDER)
     153 I $G(ORENVIR)'="GUI" D
     154 .D MSG^ORB3FUP1
     155 .;S ORLAB=$$OETOLAB^ORQQLR1(ORDER)
     156 .;Q:'$L($G(ORLAB))
     157 .;D EN1^ORCXPND(ORPT,ORLAB,"LABS")  ;api used lab # pre-6/97
     158 .D EN1^ORCXPND(ORPT,ORDER,"LABS")
     159 .D DEL^ORB3FUP1(.ORY,ORBXQAID)
     160 Q
     161RPTRAD ;radiology result follow-up for HL7-triggered notifications
     162 K XQAKILL
     163 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     164 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     165 N INVDT,CASE S INVDT="",CASE=""
     166 ;XQADATA is different for HL7-triggered vs. radiology pkg triggered
     167 S INVDT=$P(XQADATA,"~",2),CASE=$P($P(XQADATA,"~",3),"@")
     168 I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE)
     169 I $G(ORENVIR)'="GUI" D
     170 .D MSG^ORB3FUP1
     171 .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS")
     172 .D DEL^ORB3FUP1(.ORY,ORBXQAID)
     173 Q
     174RPTRAD2 ;radiology result follow-up for radiology pkg-triggered notifications
     175 K XQAKILL
     176 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     177 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     178 N INVDT,CASE S INVDT="",CASE=""
     179 ;XQADATA is different for HL7-triggered vs. radiology pkg triggered
     180 S INVDT=$P(XQADATA,"~",1),CASE=$P(XQADATA,"~",2)
     181 I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE)
     182 I $G(ORENVIR)'="GUI" D
     183 .D MSG^ORB3FUP1
     184 .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS")
     185 .D DEL^ORB3FUP1(.ORY,ORBXQAID)
     186 Q
     187EXOI ;expiring flagged orderable items follow-up
     188 K XQAKILL
     189 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL
     190 S ORBXQAID=XQAID
     191 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     192 ;the FLG code for EXPIRING orders in ORQ1 is '5'
     193 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",5,"","")
     194 I $G(ORENVIR)'="GUI" D
     195 .D MSG^ORB3FUP1
     196 .S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     197 .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL)
     198 .K ^TMP("ORR",$J)
     199 .Q:$G(ORBLMDEL)=1  ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM
     200 .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0)
     201 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X=""  I +$G(^TMP("ORR",$J,X,"TOT"))<1 D
     202 ..D DEL^ORB3FUP1(.ORY,ORBXQAID)  ;if no more EXPIRING orders found, delete the alert
     203 .K X,^TMP("ORR",$J)
     204 Q
     205INTCON ;consult interpretation follow-up
     206 K XQAKILL
     207 N NXQADATA
     208 I $G(ORENVIR)'="GUI" D
     209 .D MSG^ORB3FUP1
     210 .R !!?5,"This alert must be processed in the CPRS GUI.",X:10
     211 .K X
     212 Q
     213CHGRAD ;radiology follow-up for #67 Imaging Request Changed
     214 K XQAKILL
     215 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID
     216 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     217 I $G(ORENVIR)'="GUI" D
     218 .D MSG^ORB3FUP1
     219 .I $L($T(EN1^RAO7PC4))>0 D
     220 ..D EN1^RAO7PC4  ;display before and after change(s)
     221 ..D DEL^ORB3FUP1(.ORY,ORBXQAID)
     222 Q
     223INFODEL ;follow-up action to delete "informational" alerts
     224 K XQAKILL
     225 N ORY,ORBXQAID
     226 S ORBXQAID=XQAID
     227 D MSG^ORB3FUP1
     228 D DEL^ORB3FUP1(.ORY,ORBXQAID)
     229 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3LAB.m

    r613 r623  
    1 ORB3LAB ; slc/CLA/TC - Routine to trigger Lab-related notifications ;10/14/03
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**210,243**;Dec 17, 1997;Build 242
    3         ;
    4 LAB(ORDFN,ORLRDFN,ORLRI,ORLRA,ORLRSS,ORXQA)     ;trigger Lab Anatomic Path notifs
    5         ; called by SEND^LRAPRES1 (DBIA #4287)
    6         ;
    7         N ORBMSG,ORAPMD,ORBADUZ,ORSRPT,ORACCNO
    8         I '$D(ORXQA) D
    9         . S ORAPMD=$S(ORLRSS="AU":$P(ORLRA,U,12),1:$P(ORLRA,U,7))  ;provider/physician "ordering" the ap test
    10         . I $L(ORAPMD) S ORBADUZ(ORAPMD)=""
    11         I $D(ORXQA) M ORBADUZ=ORXQA
    12         S ORSRPT=$S($D(^LR(ORLRDFN,84,0))!($D(^LR(ORLRDFN,ORLRSS,ORLRI,1.2,0))):" supplmntl rpt",1:"") ; AP supplmntl rpt - DBIA #5157
    13         S ORBMSG=$S(ORLRSS="AU":"Autopsy",ORLRSS="CY":"Cytology",ORLRSS="SP":"Surgical Pathology",ORLRSS="EM":"Electron Microscopy",1:"Anatomic Pathology")
    14         S ORBMSG=ORBMSG_ORSRPT_" results available."
    15         S ORACCNO=$P(ORLRA,U,6)  ;accession # of lab section
    16         D EN^ORB3(71,ORDFN,"",.ORBADUZ,ORBMSG,ORLRSS_U_ORACCNO_U_ORLRI)  ;XQADATA="Lab section^Accession#^DT specimen taken (inverse format)"
    17         Q
     1ORB3LAB ; slc/CLA - Routine to trigger Lab-related notifications ;10/14/03
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**210**;Dec 17, 1997
     3 ;
     4LAB(DFN,LRDFN,LRI,LRA,LRSS) ;trigger Lab Anatomic Path notifs
     5 ; called by ADD^LRWOMEN (DBIA #4287)
     6 ;
     7 N ORBMSG,APMD,ORBADUZ,SRPT
     8 S APMD=$P(LRA,U,7)  ;provider/physician "ordering" the ap test
     9 I $L(APMD) S ORBADUZ(APMD)=""
     10 S SRPT=$P(LRA,U,15) ;original release date
     11 S SRPT=$S($L(SRPT):" supplmntl rpt",1:"")
     12 S ORBMSG=$S(LRSS="CY":"Cytology",LRSS="SP":"Surgical Pathology",1:"Anatomic Pathology")
     13 S ORBMSG=ORBMSG_SRPT_" results available."
     14 D EN^ORB3(71,DFN,"",.ORBADUZ,ORBMSG,"")
     15 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA1.m

    r613 r623  
    1 ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 3/7/2006 ]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242
    3         ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002
    4         ;
    5 ODSLCT(LST,PSTYPE,DFN,LOC)      ; return default lists for dialog
    6         ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
    7         N ILST S ILST=0
    8         S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR
    9         S ILST=ILST+1,LST(ILST)="~DispMsg"
    10         S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG
    11         ;
    12         ; I PSTYPE="F" D  Q                           ; IV Fluids
    13         ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT
    14         ;
    15         I PSTYPE="O" D                                ; Outpatient
    16         . S ILST=ILST+1,LST(ILST)="~Refills"
    17         . S ILST=ILST+1,LST(ILST)="d0^0"
    18         . S ILST=ILST+1,LST(ILST)="~Pickup"
    19         . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC))
    20         . ; S ILST=ILST+1,LST(ILST)="~Supply"
    21         . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN)
    22         Q
    23 PRIOR   ; from DLGSLCT, get list of allowed priorities
    24         N X,XREF
    25         S X=0
    26         S X=$O(^ORD(101.42,"B","DONE",X))
    27         S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2)
    28         Q
    29 DEFPICK(LOC)          ; return default routing
    30         N X,DLG,PRMT
    31         S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
    32         S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
    33         I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
    34         I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action
    35         ;
    36         S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")
    37         I X="C" S X="C^in Clinic" G XPICK
    38         I X="M" S X="M^by Mail"   G XPICK
    39         I X="W" S X="W^at Window" G XPICK
    40         I X="N" S X=""            G XPICK
    41         I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
    42 XPICK   Q X
    43         ;
    44 DEFSPLY(DFN)       ; return default days supply for this patient
    45         N ORWX
    46         S ORWX("PATIENT")=DFN
    47         D DSUP^PSOSIGDS(.ORWX)
    48         Q $G(ORWX("DAYS SUPPLY"))
    49         ;
    50 DFLTSPLY(VAL,UPD,SCH,PAT,DRG)          ; return days supply given quantity
    51         ; VAL: default days supply
    52         N ORWX,I
    53         S ORWX("PATIENT")=PAT
    54         I DRG S ORWX("DRUG")=DRG
    55         F I=1:1:$L(UPD,U)-1 D
    56         . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
    57         . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
    58         D DSUP^PSOSIGDS(.ORWX)
    59         S VAL=$G(ORWX("DAYS SUPPLY"))
    60         Q
    61 DISPMSG()             ; return 1 to suppress dispense message
    62         Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I")
    63         ;
    64 SCHALL(LST)     ; return all schedules
    65         N ILST,SCH,IEN,EXP,TYP,X0
    66         K ^TMP($J,"ORBCMA1 SCHALL")
    67         D AP^PSS51P1("PSJ",,,,"ORBCMA1 SCHALL")
    68         S ILST=0,SCH=""
    69         F  S SCH=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH)) Q:SCH=""  D
    70         . I (SCH="STAT")!(SCH="NOW") D
    71         .. S IEN=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH,""))
    72         .. S EXP=$G(^TMP($J,"ORBCMA1 SCHALL",SCH,8))
    73         .. S TYP=$P($G(^TMP($J,"ORBCMA1 SCHALL",SCH,5)),U)
    74         .. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP
    75         K ^TMP($J,"ORBCMA1 SCHALL")
    76         Q
    77 FORMALT(ORLST,IEN,PSTYPE)       ; return a list of formulary alternatives
    78         N PSID,I
    79         S IEN=+$P(^ORD(101.43,IEN,0),U,2)
    80         D EN1^PSSUTIL1(.IEN,PSTYPE)
    81         S PSID=0,I=0
    82         F  S PSID=$O(IEN(PSID)) Q:'PSID  D
    83         . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0))
    84         . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U)
    85         Q
    86 DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose
    87         N I,OI,ORWLST,ILST S ILST=0
    88         D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST)
    89         S I=0 F  S I=$O(ORWLST(I)) Q:'I  D
    90         . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0))
    91         . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U)
    92         Q
    93 FAILDEA(FAIL,OI,ORNP,PSTYPE)       ; return 1 if DEA check fails for this provider
    94         N DEAFLG,PSOI
    95         S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0
    96         I '$L($T(OIDEA^PSSUTLA1)) Q
    97         S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0
    98         I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1
    99         Q
    100 CHK94(VAL)           ; return 1 if patch 94 has been installed
    101         S VAL=0
    102         I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1
    103         Q
     1ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 2/11/02 4:30PM ]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133**;Dec 17, 1997
     3 ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002
     4 ;
     5ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog
     6 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
     7 N ILST S ILST=0
     8 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR
     9 S ILST=ILST+1,LST(ILST)="~DispMsg"
     10 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG
     11 ;
     12 ; I PSTYPE="F" D  Q                           ; IV Fluids
     13 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT
     14 ;
     15 I PSTYPE="O" D                                ; Outpatient
     16 . S ILST=ILST+1,LST(ILST)="~Refills"
     17 . S ILST=ILST+1,LST(ILST)="d0^0"
     18 . S ILST=ILST+1,LST(ILST)="~Pickup"
     19 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC))
     20 . ; S ILST=ILST+1,LST(ILST)="~Supply"
     21 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN)
     22 Q
     23PRIOR ; from DLGSLCT, get list of allowed priorities
     24 N X,XREF
     25 S X=0
     26 S X=$O(^ORD(101.42,"B","DONE",X))
     27 S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2)
     28 Q
     29DEFPICK(LOC)       ; return default routing
     30 N X,DLG,PRMT
     31 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
     32 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
     33 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
     34 I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action
     35 ;
     36 S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")
     37 I X="C" S X="C^in Clinic" G XPICK
     38 I X="M" S X="M^by Mail"   G XPICK
     39 I X="W" S X="W^at Window" G XPICK
     40 I X="N" S X=""            G XPICK
     41 I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
     42XPICK Q X
     43 ;
     44DEFSPLY(DFN)    ; return default days supply for this patient
     45 N ORWX
     46 S ORWX("PATIENT")=DFN
     47 D DSUP^PSOSIGDS(.ORWX)
     48 Q $G(ORWX("DAYS SUPPLY"))
     49 ;
     50DFLTSPLY(VAL,UPD,SCH,PAT,DRG)        ; return days supply given quantity
     51 ; VAL: default days supply
     52 N ORWX,I
     53 S ORWX("PATIENT")=PAT
     54 I DRG S ORWX("DRUG")=DRG
     55 F I=1:1:$L(UPD,U)-1 D
     56 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
     57 . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
     58 D DSUP^PSOSIGDS(.ORWX)
     59 S VAL=$G(ORWX("DAYS SUPPLY"))
     60 Q
     61DISPMSG()       ; return 1 to suppress dispense message
     62 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I")
     63 ;
     64SCHALL(LST) ; return all schedules
     65 N ILST,SCH,IEN,EXP,TYP,X0
     66 S ILST=0,SCH=""
     67 F  S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH=""  D
     68 . I (SCH="STAT")!(SCH="NOW") D
     69 .. S IEN=$O(^PS(51.1,"APPSJ",SCH,0))
     70 .. S X0=$G(^PS(51.1,IEN,0)),EXP=$P(X0,U,8),TYP=$P(X0,U,5)
     71 .. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP
     72 Q
     73FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
     74 N PSID,I
     75 S IEN=+$P(^ORD(101.43,IEN,0),U,2)
     76 D EN1^PSSUTIL1(.IEN,PSTYPE)
     77 S PSID=0,I=0
     78 F  S PSID=$O(IEN(PSID)) Q:'PSID  D
     79 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0))
     80 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U)
     81 Q
     82DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose
     83 N I,OI,ORWLST,ILST S ILST=0
     84 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST)
     85 S I=0 F  S I=$O(ORWLST(I)) Q:'I  D
     86 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0))
     87 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U)
     88 Q
     89FAILDEA(FAIL,OI,ORNP,PSTYPE)    ; return 1 if DEA check fails for this provider
     90 N DEAFLG,PSOI
     91 S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0
     92 I '$L($T(OIDEA^PSSUTLA1)) Q
     93 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0
     94 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1
     95 Q
     96CHK94(VAL)      ; return 1 if patch 94 has been installed
     97 S VAL=0
     98 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1
     99 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m

    r613 r623  
    1 ORBCMA32        ; SLC/JLI - Pharmacy Calls for GUI Dialog 02/11/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242
    3         ;;BCMA ORDER V1.0 ;**133,243**;Jan 17, 2002
    4         ;
    5 NXT()   ; -- returns next available index in return data array
    6         S ILST=ILST+1
    7         Q ILST
    8         ;
    9 DLGSLCT(LST,PSTYPE)     ; return default lists for dialog
    10         ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
    11         N ILST S ILST=0
    12         I PSTYPE="F" D  Q                       ; IV Fluids
    13         . S LST($$NXT)="~ShortList"  D SHORT
    14         . S LST($$NXT)="~Priorities" D PRIOR
    15         ;
    16         S LST($$NXT)="~ShortList"  D SHORT      ; Unit Dose & Outpatient
    17         S LST($$NXT)="~Schedules"  D SCHED
    18         S LST($$NXT)="~Priorities" D PRIOR
    19         I PSTYPE="O" D                          ; Outpatient
    20         . S LST($$NXT)="~Pickup"   D PICKUP
    21         . S LST($$NXT)="~SCStatus" D SCLIST
    22         Q
    23 SHORT   ; from DLGSLCT, get short list of med quick orders
    24         N I,X,TMP
    25         I PSTYPE="U" S X="UD RX"
    26         I PSTYPE="F" S X="IV RX"
    27         I PSTYPE="O" S X="O RX"
    28         D GETQLST^ORWDXQ(.TMP,X,"iQ")
    29         S I=0 F  S I=$O(TMP(I)) Q:'I  S LST($$NXT)=TMP(I)
    30         Q
    31 SCHED   ; from DLGSLCT, get all pharmacy administration schedules
    32         N X
    33         K ^TMP($J,"ORBCMA32 SCHED")
    34         D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHED")
    35         S X="" F  S X=$O(^TMP($J,"ORBCMA32 SCHED","APPSJ",X)) Q:X=""  S LST($$NXT)="i"_X
    36         K ^TMP($J,"ORBCMA32 SCHED")
    37         Q
    38 SCHEDA  ; (similar to SCHED, but also returns administration times)
    39         N X,IEN,SCH
    40         K ^TMP($J,"ORBCMA32 SCHEDA")
    41         D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHEDA")
    42         S SCH="" F  S SCH=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH)) Q:SCH=""  D
    43         . S IEN=0 F  S IEN=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0  D
    44         . . S X=$S($L(^TMP($J,"ORBCMA32 SCHEDA",IEN,2)):"  ("_^TMP($J,"ORBCMA32 SCHEDA",IEN,2)_")",1:"")
    45         . . S LST($$NXT)="i"_IEN_U_SCH_X
    46         Q
    47 PRIOR   ; from DLGSLCT, get list of allowed priorities
    48         N X,XREF
    49         S X=0
    50         S X=$O(^ORD(101.42,"B","DONE",X))
    51         S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2)
    52         Q
    53 PICKUP  ; from DLGSLCT, get prescription routing
    54         N X,EDITONLY
    55         F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
    56         S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
    57         Q
    58 DEFPICK()             ; return default routing
    59         N X,DLG,PRMT
    60         S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
    61         S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
    62         I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
    63         I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action
    64         ;
    65         S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
    66         I X="C" S X="C^in Clinic" G XPICK
    67         I X="M" S X="M^by Mail"   G XPICK
    68         I X="W" S X="W^at Window" G XPICK
    69         I X="N" S X=""             G XPICK
    70         I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
    71 XPICK   Q X
    72         ;
    73 SCLIST  ; from DLGSLCT, get options for service connected
    74         F X="0^No","1^Yes" S LST($$NXT)="i"_X
    75         Q
    76         ;
    77 OISLCT(LST,OI,PSTYPE,ORVP)      ; return for defaults for pharmacy orderable item
    78         N ILST S ILST=0
    79         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    80         S LST($$NXT)="~Dispense" D DISPDRG
    81         S LST($$NXT)="~Instruct" D INSTRCT
    82         S LST($$NXT)="~Route"    D ROUTE
    83         S LST($$NXT)="~Message"  D MESSAGE
    84         I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
    85         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    86         Q
    87         ;
    88 DISPDRUG(LST,OI)        ; list dispense drugs for an orderable item
    89         N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
    90         Q
    91         ;
    92 DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item
    93         N I,ORTMP,ORX
    94         S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
    95         I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
    96         I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
    97         S I="" F  S I=$O(ORTMP(I)) Q:I=""  D
    98         . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
    99         . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
    100         . S LST($$NXT)="i"_ORTMP(I)
    101         Q
    102 INSTRCT ; from OISLCT, get list of potential instructions (based on drug form)
    103         N INOUN,NOUN,IINS,INS,VERB,INSREC
    104         D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
    105         I PSTYPE="U" Q  ; don't use the instructions list for inpatients
    106         S IINS=0 F  S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS  D
    107         . S INSREC=$G(^TMP("PSJINS",$J,IINS))
    108         . I '$D(VERB) S VERB=$P(INSREC,U)
    109         . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
    110         S LST($$NXT)="~Nouns"
    111         S INOUN=0 F  S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN  D
    112         . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
    113         I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
    114         ;
    115         Q
    116 MIXED(X)          ; Return mixed case
    117         Q X  ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
    118         ;
    119 ROUTE   ; from OISLCT, get list of routes for the drug form
    120         ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
    121         N I,CNT,ABBR,IEN,ROUT,X
    122         S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
    123         . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
    124         . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
    125         . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
    126         S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
    127         . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
    128         . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
    129         Q
    130 MESSAGE ; message
    131         S I=0 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  S LST($$NXT)="t"_^(I,0)
    132         Q
    133 ALLROUTE(LST)   ; returns a list of all available med routes
    134         N I,X,ILST
    135         S ILST=0
    136         K ^TMP($J,"ORWDPS32 ALLROUTE")
    137         D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
    138         S I=0 F  S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I  D
    139         . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1)
    140         Q
    141 VALROUTE(REC,X)        ; validates route name & returns IEN + abbreviation
    142         N ABBR,NAME,IEN
    143         K ^TMP($J,"ORBCMA32 VALROUTE")
    144         S X=$$UPPER(X)
    145         D ALL^PSS51P2(,X,,1,"ORBCMA32 VALROUTE")
    146         I $P(^TMP($J,"ORBCMA32 VALROUTE",0),U)=-1 K ^TMP($J,"ORBCMA32 VALROUTE") S REC=0 Q
    147         S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","B",X,""))
    148         I IEN'>0 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","C",X,""))
    149         I IEN'>0 S REC=0 Q
    150         S NAME=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,.01))
    151         S ABBR=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,1))
    152         I '$L(ABBR) S ABBR=NAME
    153         I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORBCMA32 VALROUTE") Q
    154         S REC=IEN_U_ABBR
    155         K ^TMP($J,"ORBCMA32 VALROUTE")
    156         Q
    157 AUTH(VAL,PRV)   ; For inpatient meds, check restrictions
    158         N NAME,AUTH,INACT,X S VAL=0
    159         S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
    160         S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
    161         I 'AUTH!(INACT&(DT>INACT)) D  Q
    162         . S VAL="1^"_NAME_" is not authorized to write medication orders."
    163         I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D  Q
    164         . S VAL="1^OREMAS key holders may not enter medication orders."
    165         Q
    166 DRUGMSG(VAL,IEN)               ; return any message associated with a dispense drug
    167         N X S X=$$ENDCM^PSJORUTL(IEN)
    168         S VAL=$P(X,U,2)_U_$P(X,U,4)
    169         Q
    170 MEDISIV(VAL,IEN)               ; return true if orderable item is IV medication
    171         S VAL=0
    172         I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
    173         Q
    174 ISSPLY(VAL,IEN) ; return true if orderable item is a supply
    175         S VAL=0
    176         I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
    177         Q
    178 IVAMT(VAL,OI,ORWTYP)        ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
    179         N I,PSOI,ORWY,AMT,IVFLAG
    180         S IVFLAG=$P(OI,U,2)
    181         S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL=""
    182         I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY)
    183         I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY)
    184         I ORWTYP="B" D
    185         . S I=0 F  S I=$O(ORWY(I)) Q:I'>0  S AMT(+ORWY(I))=""
    186         . S AMT=0,VAL="ML" F  S AMT=$O(AMT(AMT)) Q:AMT'>0  S VAL=VAL_U_AMT
    187         I ORWTYP="A" D
    188         . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
    189         . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL"
    190         Q
    191 VALRATE(VAL,X)    ; return "1" (true) if IV rate text is valid
    192         I $E($RE($$UPPER(X)),1,5)="RH/LM"  S X=$E(X,1,$L(X)-5)
    193         S X=$$TRIM(X)
    194         D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0)
    195         Q
    196 UPPER(X)        ; return uppercase
    197         Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    198         ;
    199 TRIM(X) ; trim leading and trailing spaces
    200         S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;trail
    201         S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;lead
    202         Q X
    203 SCSTS(VAL,ORVP,ORDRUG)   ; return service connected eligibility for patient
    204         N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
    205         I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
    206         I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
    207         S VAL=1
    208 XSCSTS  Q
    209 FORMALT(ORLST,IEN,PSTYPE)       ; return a list of formulary alternatives
    210         D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
    211         S I=0 F  S I=$O(ORLST(I)) Q:'I  D
    212         . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
    213         . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
    214         Q
    215 VALSCH(OK,X,PSTYPE)        ; validate a schedule, return 1 if valid, 0 if not
    216         I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
    217         I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
    218         . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
    219         . K X S:$D(ORX) X=ORX
    220         E  D
    221         . D EN^PSSGSGUI
    222         S OK=$S($D(X):1,1:0)
    223         Q
    224 VALQTY(OK,X)       ; validate a quantity, return 1 if valid, 0 if not
    225         ; to be compatible with LM, make sure X is integer from 1 to 240
    226         ; this is based on the input transform from 52,7
    227         K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
    228         S OK=$S($D(X):1,1:0)
    229         Q
    230 DOSES(LST,OI)   ; return doses for an orderable item  -  TEST ONLY
    231         N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O"
    232         D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
    233         S ORI=0 F  S ORI=$O(ORTMP(ORI)) Q:'ORI  S ORWDRG=+ORTMP(ORI) D
    234         . K ^TMP($J,"ORBCMA32 DRUG")
    235         . D NDF^PSS50(+ORWDRG,,,,,"ORBCMA32 DRUG")
    236         . S VAPN=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,20)),U)
    237         . S X=$$DFSU^PSNAPIS(NDF,VAPN)
    238         . S LSTA($P(X,U,4),$P(X,U,6))=""
    239         . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
    240         K ^TMP($J,"ORBCMA32 DRUG")
    241         S ORI="",ILST=0 F  S ORI=$O(LSTA(ORI)) Q:ORI=""  D
    242         . S ORJ="" F  S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ=""  D
    243         . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
    244         Q
     1ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog ;01/17/02
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,237**;Dec 17, 1997
     3 ;;BCMA ORDER V1.0 ;**133,237**;Jan 17, 2002
     4 ;
     5NXT() ; -- returns next available index in return data array
     6 S ILST=ILST+1
     7 Q ILST
     8 ;
     9DLGSLCT(LST,PSTYPE) ; return default lists for dialog
     10 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
     11 N ILST S ILST=0
     12 I PSTYPE="F" D  Q                       ; IV Fluids
     13 . S LST($$NXT)="~ShortList"  D SHORT
     14 . S LST($$NXT)="~Priorities" D PRIOR
     15 ;
     16 S LST($$NXT)="~ShortList"  D SHORT      ; Unit Dose & Outpatient
     17 S LST($$NXT)="~Schedules"  D SCHED
     18 S LST($$NXT)="~Priorities" D PRIOR
     19 I PSTYPE="O" D                          ; Outpatient
     20 . S LST($$NXT)="~Pickup"   D PICKUP
     21 . S LST($$NXT)="~SCStatus" D SCLIST
     22 Q
     23SHORT ; from DLGSLCT, get short list of med quick orders
     24 ; !!! change this so that it uses the ORWDXQ call!!!
     25 N I,X,TMP
     26 I PSTYPE="U" S X="UD RX"
     27 I PSTYPE="F" S X="IV RX"
     28 I PSTYPE="O" S X="O RX"
     29 D GETQLST^ORWDXQ(.TMP,X,"iQ")
     30 S I=0 F  S I=$O(TMP(I)) Q:'I  S LST($$NXT)=TMP(I)
     31 Q
     32SCHED ; from DLGSLCT, get all pharmacy administration schedules
     33 N X
     34 S X="" F  S X=$O(^PS(51.1,"APPSJ",X)) Q:X=""  S LST($$NXT)="i"_X
     35 Q
     36SCHEDA ; (similar to SCHED, but also returns administration times)
     37 N X,IEN,SCH
     38 S SCH="" F  S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH=""  D
     39 . S IEN=0 F  S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0  D
     40 . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):"  ("_$P(X,U,2)_")",1:"")
     41 . . S LST($$NXT)="i"_IEN_U_SCH_X
     42 Q
     43PRIOR ; from DLGSLCT, get list of allowed priorities
     44 N X,XREF
     45 S X=0
     46 S X=$O(^ORD(101.42,"B","DONE",X))
     47 S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2)
     48 Q
     49PICKUP ; from DLGSLCT, get prescription routing
     50 N X,EDITONLY
     51 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
     52 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
     53 Q
     54DEFPICK()       ; return default routing
     55 N X,DLG,PRMT
     56 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
     57 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
     58 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
     59 I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action
     60 ;
     61 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
     62 I X="C" S X="C^in Clinic" G XPICK
     63 I X="M" S X="M^by Mail"   G XPICK
     64 I X="W" S X="W^at Window" G XPICK
     65 I X="N" S X=""             G XPICK
     66 I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
     67XPICK Q X
     68 ;
     69SCLIST ; from DLGSLCT, get options for service connected
     70 F X="0^No","1^Yes" S LST($$NXT)="i"_X
     71 Q
     72 ;
     73OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item
     74 N ILST S ILST=0
     75 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     76 S LST($$NXT)="~Dispense" D DISPDRG
     77 S LST($$NXT)="~Instruct" D INSTRCT
     78 S LST($$NXT)="~Route"    D ROUTE
     79 S LST($$NXT)="~Message"  D MESSAGE
     80 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
     81 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     82 Q
     83 ;
     84DISPDRUG(LST,OI) ; list dispense drugs for an orderable item
     85 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
     86 Q
     87 ;
     88DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item
     89 N I,ORTMP,ORX
     90 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
     91 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
     92 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
     93 S I="" F  S I=$O(ORTMP(I)) Q:I=""  D
     94 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
     95 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
     96 . S LST($$NXT)="i"_ORTMP(I)
     97 Q
     98INSTRCT ; from OISLCT, get list of potential instructions (based on drug form)
     99 N INOUN,NOUN,IINS,INS,VERB,INSREC
     100 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
     101 I PSTYPE="U" Q  ; don't use the instructions list for inpatients
     102 S IINS=0 F  S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS  D
     103 . S INSREC=$G(^TMP("PSJINS",$J,IINS))
     104 . I '$D(VERB) S VERB=$P(INSREC,U)
     105 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
     106 S LST($$NXT)="~Nouns"
     107 S INOUN=0 F  S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN  D
     108 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
     109 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
     110 ;
     111 Q
     112MIXED(X)   ; Return mixed case
     113 Q X  ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
     114 ;
     115ROUTE ; from OISLCT, get list of routes for the drug form
     116 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
     117 N I,CNT,ABBR,IEN,ROUT,X
     118 S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
     119 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
     120 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
     121 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
     122 S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
     123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
     124 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
     125 Q
     126MESSAGE ; message
     127 S I=0 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  S LST($$NXT)="t"_^(I,0)
     128 Q
     129ALLROUTE(LST) ; returns a list of all available med routes
     130 N I,X,ILST S ILST=0
     131 S I=0 F  S I=$O(^PS(51.2,I)) Q:'I  S X=^(I,0) D
     132 . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3)
     133 Q
     134VALROUTE(REC,X)        ; validates route name & returns IEN + abbreviation
     135 N ORLST,ABBR
     136 D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST")
     137 I 'ORLST("DILIST",0) S REC=0 Q
     138 S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1)
     139 I '$L(ABBR) S ABBR=ORLST("DILIST",1,1)
     140 I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q
     141 S REC=ORLST("DILIST",2,1)_U_ABBR
     142 Q
     143AUTH(VAL,PRV) ; For inpatient meds, check restrictions
     144 N NAME,AUTH,INACT,X S VAL=0
     145 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
     146 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
     147 I 'AUTH!(INACT&(DT>INACT)) D  Q
     148 . S VAL="1^"_NAME_" is not authorized to write medication orders."
     149 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D  Q
     150 . S VAL="1^OREMAS key holders may not enter medication orders."
     151 Q
     152DRUGMSG(VAL,IEN)        ; return any message associated with a dispense drug
     153 N X S X=$$ENDCM^PSJORUTL(IEN)
     154 S VAL=$P(X,U,2)_U_$P(X,U,4)
     155 Q
     156MEDISIV(VAL,IEN)        ; return true if orderable item is IV medication
     157 S VAL=0
     158 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
     159 Q
     160ISSPLY(VAL,IEN) ; return true if orderable item is a supply
     161 S VAL=0
     162 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
     163 Q
     164IVAMT(VAL,OI,ORWTYP)     ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
     165 N I,PSOI,ORWY,AMT,IVFLAG
     166 S IVFLAG=$P(OI,U,2)
     167 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL=""
     168 I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY)
     169 I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY)
     170 I ORWTYP="B" D
     171 . S I=0 F  S I=$O(ORWY(I)) Q:I'>0  S AMT(+ORWY(I))=""
     172 . S AMT=0,VAL="ML" F  S AMT=$O(AMT(AMT)) Q:AMT'>0  S VAL=VAL_U_AMT
     173 I ORWTYP="A" D
     174 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
     175 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM"
     176 Q
     177VALRATE(VAL,X)   ; return "1" (true) if IV rate text is valid
     178 I $E($RE($$UPPER(X)),1,5)="RH/LM"  S X=$E(X,1,$L(X)-5)
     179 S X=$$TRIM(X)
     180 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0)
     181 Q
     182UPPER(X) ; return uppercase
     183 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     184 ;
     185TRIM(X) ; trim leading and trailing spaces
     186 S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;trail
     187 S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;lead
     188 Q X
     189SCSTS(VAL,ORVP,ORDRUG)  ; return service connected eligibility for patient
     190 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
     191 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
     192 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
     193 S VAL=1
     194XSCSTS Q
     195FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
     196 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
     197 S I=0 F  S I=$O(ORLST(I)) Q:'I  D
     198 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
     199 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
     200 Q
     201VALSCH(OK,X,PSTYPE)    ; validate a schedule, return 1 if valid, 0 if not
     202 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
     203 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
     204 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
     205 . K X S:$D(ORX) X=ORX
     206 E  D
     207 . D EN^PSSGSGUI
     208 S OK=$S($D(X):1,1:0)
     209 Q
     210VALQTY(OK,X)    ; validate a quantity, return 1 if valid, 0 if not
     211 ; to be compatible with LM, make sure X is integer from 1 to 240
     212 ; this is based on the input transform from 52,7
     213 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
     214 S OK=$S($D(X):1,1:0)
     215 Q
     216DOSES(LST,OI) ; return doses for an orderable item  -  TEST ONLY
     217 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O"
     218 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
     219 S ORI=0 F  S ORI=$O(ORTMP(ORI)) Q:'ORI  S ORWDRG=+ORTMP(ORI) D
     220 . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF
     221 . S X=$$DFSU^PSNAPIS(NDF,VAPN)
     222 . S LSTA($P(X,U,4),$P(X,U,6))=""
     223 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
     224 S ORI="",ILST=0 F  S ORI=$O(LSTA(ORI)) Q:ORI=""  D
     225 . S ORJ="" F  S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ=""  D
     226 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
     227 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT0.m

    r613 r623  
    1 ORCACT0 ;SLC/MKB-Validate order action ;5/19/08
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 VALID(IFN,ACTION,ERROR,NATR)    ; -- Determines if action is valid for order IFN
    5         N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR
    6         S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14))
    7         S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3)
    8         S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS"))
    9         S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7)
    10         S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15)
    11         S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2)
    12 CM      I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions
    13 FL      I ACTION="FL" D  G VQ ; flag
    14         . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q
    15 UF      I ACTION="UF" D  G VQ ; unflag
    16         . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q
    17 DC1     I ACTION="DC",ACTSTS D  G VQ ; discontinue/cancel unrel or canc order
    18         . I (ACTSTS=11)!(ACTSTS=10) D  Q  ; unreleased
    19         .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q
    20         .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q
    21         . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q
    22         . I ACTSTS=13 S ERROR="This order has been cancelled!" Q
    23 ES      I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign
    24 VR      I ACTION="VR" D  G VQ ; verify
    25         . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q
    26         . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q
    27         . I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q
    28         . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q
    29         . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q
    30 DIS     S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ
    31 MN      I ACTION="MN" D  G VQ ; manually release (delayed)
    32         . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q
    33         . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!"
    34 GMRA    I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies
    35 MEDS    I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ
    36 RW      I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy
    37 XFR     I ACTION="XFR" D XFR^ORCACT01 G VQ ; transfer to in/outpt
    38 RN      I ACTION="RN" D RN^ORCACT01 G VQ ; renew
    39 TRM     I $$DONE G VQ ; ORDSTS=1,2,7,12,13
    40 EV      I ACTION="EV" D  G VQ ; change delay event
    41         . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q
    42         . I DG="NV RX" S ERROR="Non-VA Med orders do not support this action!" Q
    43         . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q
    44         . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q
    45 DC2     I ACTION="DC",ACTSTS="" D  G VQ ; DC released order
    46         . I $G(NATR)="A" D  Q:$D(ERROR)
    47         .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q
    48         .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q  ;177 If admission auto-dc and order is outpt med then no further checking needed
    49         .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q
    50         .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C",PKG'="PS" S ERROR="Only inpatient orders may be auto-discontinued!" Q
    51         . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q
    52         . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q
    53         . I PKG="LR" D  Q
    54         .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q
    55         .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'<DT S ERROR="Future Send Patient orders may not be auto-discontinued!" Q
    56         . I PKG="GMRC",ORDSTS=9 S ERROR="Consults orders with partial results cannot be discontinued!" Q
    57         . I DG="DO",$G(DGPMT)'=3,ORDSTS=6,'$$NPO(+IFN) S ERROR="Active Diets cannot be discontinued; please order a new diet!" Q
    58 RL      I ACTION="RL" D  G VQ  ; release hold
    59         . I ORDSTS'=3 D  Q
    60         ..I $P(ORA0,U,4)=2 S ERROR="Providers has not yet signed the hold order and therefor it cannot yet be released" Q
    61         ..S ERROR="Orders not on hold cannot be released!" Q
    62         . I ACTSTS S ERROR=$$ACTION($P(ORA0,U,2))_" orders cannot be released from hold!" Q
    63         . N NATR,ACT S ACT=$S($P(ORA0,U,2)="HD":AIFN,1:+$P(OR3,U,7))
    64         . S NATR=+$P($G(^OR(100,+IFN,8,ACT,0)),U,12),ACT=$P($G(^(0)),U,2)
    65         . I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") S ERROR="Orders held by a service must be released from hold through the service!" Q
    66 AIFN    S X=$P(ORA0,U,2) I AIFN>1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ
    67 RF      I ACTION="RF" D  G VQ
    68         . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q
    69         . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q
    70         . I ORDSTS=7 S ERROR="Expired orders may not be refilled!" Q
    71         . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4))
    72         . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q
    73 CP      I ACTION="CP" D  G VQ ; complete
    74         . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q
    75         . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q
    76 AL      I ACTION="AL" D  G VQ
    77         . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q
    78         . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q
    79 XX      I ACTION="XX" D  G VQ ; edit/change
    80         . I ORDSTS=7 S ERROR="Expired orders may not be changed!" Q
    81         . D XX^ORCACT01
    82 HD      I ACTION="HD" D  G VQ ; hold
    83         . I PKG="FH" S ERROR="Diet orders cannot be held!" Q
    84         . I PKG="LR" S ERROR="Lab orders cannot be held!" Q
    85         . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q
    86         . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q
    87         . I DG="NV RX" S ERROR="Non-VA Med orders cannot be held!" Q
    88         . I ORDSTS=3 S ERROR="This order is already on hold!" Q
    89         . I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q
    90         . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
    91 VQ      S Y=$S($D(ERROR):0,1:1)
    92         Q Y
    93         ;
    94 ACTION(X)       ; -- Return text of action X
    95         N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X)
    96         Q Y
    97         ;
    98 NPO(ORIFN)      ; -- Returns 1 or 0, if order ORIFN is for NPO
    99         N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E")
    100         S Y=$S($E(X,1,3)="NPO":1,1:0)
    101         Q Y
    102         ;
    103 COLLECTD()      ; -- Lab order collected/active (incl all children)?
    104         I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased
    105         I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5)
    106         ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending
    107         N Y,Z S Y=1,Z=0
    108         F  S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0  I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q
    109         Q Y
    110         ;
    111 DONE()  ; -- sets ERROR if terminal status
    112         I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1
    113         I ORDSTS=2 S ERROR="This order has been completed!" Q 1
    114         I ORDSTS=7,DG'="O RX" S ERROR="This order has expired!" Q 1
    115         I ORDSTS=12 S ERROR="This order has been changed!" Q 1
    116         I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1
    117         I ORDSTS=14 S ERROR="This order has lapsed!" Q 1
    118         I ORDSTS=15 S ERROR="This order has been renewed!" Q 1
    119         Q 0
    120         ;
    121 DISABLED()      ; -- Order dialog [or protocol] disabled?
    122         N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X
    123         I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X
    124         S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"")
    125         I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG)
    126         Q X
     1ORCACT0 ;SLC/MKB-Validate order action ;2/24/03  10:35
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,215**;Dec 17, 1997
     3 ;
     4VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN
     5 N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR
     6 S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14))
     7 S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3)
     8 S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS"))
     9 S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7)
     10 S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15)
     11 S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2)
     12CM I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions
     13FL I ACTION="FL" D  G VQ ; flag
     14 . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q
     15UF I ACTION="UF" D  G VQ ; unflag
     16 . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q
     17DC1 I ACTION="DC",ACTSTS D  G VQ ; discontinue/cancel unrel or canc order
     18 . I (ACTSTS=11)!(ACTSTS=10) D  Q  ; unreleased
     19 .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q
     20 .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q
     21 . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q
     22 . I ACTSTS=13 S ERROR="This order has been cancelled!" Q
     23ES I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign
     24VR I ACTION="VR" D  G VQ ; verify
     25 . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q
     26 . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q
     27 . I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q
     28 . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q
     29 . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q
     30DIS S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ
     31MN I ACTION="MN" D  G VQ ; manually release (delayed)
     32 . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q
     33 . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!"
     34GMRA I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies
     35MEDS I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ
     36RW I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy
     37XFR I ACTION="XFR" D XFR^ORCACT01 G VQ ; transfer to in/outpt
     38RN I ACTION="RN" D RN^ORCACT01 G VQ ; renew
     39TRM I $$DONE G VQ ; ORDSTS=1,2,7,12,13
     40EV I ACTION="EV" D  G VQ ; change delay event
     41 . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q
     42 . I DG="NV RX" S ERROR="Non-VA Med orders do not support this action!" Q
     43 . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q
     44 . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q
     45DC2 I ACTION="DC",ACTSTS="" D  G VQ ; DC released order
     46 . I $G(NATR)="A" D  Q:$D(ERROR)
     47 .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q
     48 .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q  ;177 If admission auto-dc and order is outpt med then no further checking needed
     49 .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q
     50 .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C" S ERROR="Only inpatient orders may be auto-discontinued!" Q
     51 . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q
     52 . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q
     53 . I PKG="LR" D  Q
     54 .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q
     55 .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'<DT S ERROR="Future Send Patient orders may not be auto-discontinued!" Q
     56 . I PKG="GMRC",ORDSTS=9 S ERROR="Consults orders with partial results cannot be discontinued!" Q
     57 . I DG="DO",$G(DGPMT)'=3,ORDSTS=6,'$$NPO(+IFN) S ERROR="Active Diets cannot be discontinued; please order a new diet!" Q
     58RL I ACTION="RL" D  G VQ  ; release hold
     59 . I ORDSTS'=3 S ERROR="Orders not on hold cannot be released!" Q
     60 . I ACTSTS S ERROR=$$ACTION($P(ORA0,U,2))_" orders cannot be released from hold!" Q
     61 . N NATR,ACT S ACT=$S($P(ORA0,U,2)="HD":AIFN,1:+$P(OR3,U,7))
     62 . S NATR=+$P($G(^OR(100,+IFN,8,ACT,0)),U,12),ACT=$P($G(^(0)),U,2)
     63 . I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") S ERROR="Orders held by a service must be released from hold through the service!" Q
     64AIFN S X=$P(ORA0,U,2) I AIFN>1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ
     65RF I ACTION="RF" D  G VQ
     66 . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q
     67 . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q
     68 . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4))
     69 . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q
     70CP I ACTION="CP" D  G VQ ; complete
     71 . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q
     72 . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q
     73AL I ACTION="AL" D  G VQ
     74 . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q
     75 . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q
     76XX I ACTION="XX" D XX^ORCACT01 G VQ ; edit/change
     77HD I ACTION="HD" D  G VQ ; hold
     78 . I PKG="FH" S ERROR="Diet orders cannot be held!" Q
     79 . I PKG="LR" S ERROR="Lab orders cannot be held!" Q
     80 . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q
     81 . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q
     82 . I DG="NV RX" S ERROR="Non-VA Med orders cannot be held!" Q
     83 . I ORDSTS=3 S ERROR="This order is already on hold!" Q
     84 . I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q
     85 . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
     86VQ S Y=$S($D(ERROR):0,1:1)
     87 Q Y
     88 ;
     89ACTION(X) ; -- Return text of action X
     90 N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X)
     91 Q Y
     92 ;
     93NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO
     94 N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E")
     95 S Y=$S($E(X,1,3)="NPO":1,1:0)
     96 Q Y
     97 ;
     98COLLECTD() ; -- Lab order collected/active (incl all children)?
     99 I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased
     100 I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5)
     101 ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending
     102 N Y,Z S Y=1,Z=0
     103 F  S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0  I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q
     104 Q Y
     105 ;
     106DONE() ; -- sets ERROR if terminal status
     107 I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1
     108 I ORDSTS=2 S ERROR="This order has been completed!" Q 1
     109 I ORDSTS=7 S ERROR="This order has expired!" Q 1
     110 I ORDSTS=12 S ERROR="This order has been changed!" Q 1
     111 I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1
     112 I ORDSTS=14 S ERROR="This order has lapsed!" Q 1
     113 I ORDSTS=15 S ERROR="This order has been renewed!" Q 1
     114 Q 0
     115 ;
     116DISABLED() ; -- Order dialog [or protocol] disabled?
     117 N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X
     118 I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X
     119 S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"")
     120 I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG)
     121 Q X

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT01.m

    r613 r623  
    1 ORCACT01        ;SLC/MKB-Validate order actions cont ;03/28/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213,243**;Dec 17, 1997;Build 242
    3         ;
    4 ES      ; -- sign [on chart]
    5         I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q
    6         N X I ACTSTS=11!(ACTSTS=10) D  Q:$L($G(ERROR))
    7         . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q
    8         . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q
    9         I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q
    10         S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q
    11         I X'=2 S ERROR="This order has been signed!" Q
    12         I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q
    13         I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q
    14         I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q
    15         I ACTION="RS" D  Q:$D(ERROR)  Q:$G(NATR)'="I"
    16         . Q:ACTSTS=11  Q:ACTSTS=10  ;unreleased - ok
    17         . S ERROR="This order has already been released!"
    18 ES1     I PKG="PS" D  ;authorized to write meds?
    19         . N TYPE,OI,PSOI,DEAFLG,PKI,IVERROR
    20         . S X=$G(^VA(200,DUZ,"PS"))
    21         . I '$P(X,U) S ERROR="You are not authorized to sign med orders!" Q
    22         . I $P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q
    23         . ;Q:DG="IV RX"  Q:$P(ORA0,U,2)="DC"  ;don't need to ck DEA#
    24         . Q:$P(ORA0,U,2)="DC"
    25         . I DG="IV RX" D  Q
    26         . .I $$IVDEACHK(+IFN)=1 S ERROR="You must have a valid DEA# or VA# to sign this order!"
    27         . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE")
    28         . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0
    29         . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$$OIDEA^PSSUTLA1(PSOI,TYPE)
    30         . I (DEAFLG>0||$$ISCLOZ^ORALWORD(OI)),'$L($$DEA^XUSER()) S ERROR="You must have a valid DEA# or VA# to sign this order!" Q
    31         . D PKISITE^ORWOR(.PKI)
    32         . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q
    33         Q
    34         ;
    35 IVDEACHK(IFN)   ; -- Returns value of prompt by ID
    36         I '$G(IFN)!('$D(^OR(100,+$G(IFN),0))) Q ""
    37         N I,DIAL,DIALTYP,FAIL,PATCLASS,RESULT,Y
    38         S PATCLASS=$P(^OR(100,+IFN,0),U,12)
    39         S RESULT=0
    40         ;if ORNP is not set then assume this is called from VistA not CPRS
    41         I $G(ORNP)="" S ORNP=DUZ
    42         S I=0,Y="" S:'$G(INST) INST=1
    43         F  S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0!(RESULT=1)  D
    44         .S Y=$G(^OR(100,+IFN,4.5,I,1)) Q:Y'>0
    45         .;S PSOI=+$P($G(^ORD(101.43,Y,0)),U,2) Q:PSOI'>0
    46         .I PATCLASS="I" D  Q
    47         ..D FAILDEA^ORWDPS1(.FAIL,Y,ORNP,"I") I FAIL=1 S RESULT=1
    48         .S DIAL=+$P(^OR(100,+IFN,4.5,I,0),U,2)
    49         .S DIALTYP=$S($P(^ORD(101.41,DIAL,0),U)["ADDITIVE":"A",1:"S")
    50         .D FDEA1^ORWDPS1(.FAIL,Y,DIALTYP,ORNP)
    51         .I FAIL=1 S RESULT=1
    52         .;I $$OIDEA^PSSUTLA1(PSOI,"I")>0 S RESULT=1 Q
    53         Q RESULT
    54         ;
    55 XFR     ; -- transfer to inpt/outpt [IFN=order to be transferred]
    56         N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q
    57         I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q
    58         S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS"))
    59         I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q
    60         I DG="O RX" D  Q:$L($G(ERROR))
    61         . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q
    62         . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN)
    63         Q
    64         ;
    65 RW      ; -- rewrite/copy
    66         I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q
    67         I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q
    68         I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q
    69         I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q
    70         I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q
    71         I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
    72         I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
    73         Q
    74         ;
    75 RN      ; -- renew
    76         I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q
    77         I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
    78         I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q
    79         I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q
    80         I PKG="OR" D  Q  ;Generic orders
    81         . I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q
    82         . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q
    83         . I "^1^2^6^7^"[(U_ORDSTS_U) Q  ;ok
    84         . S ERROR="This order may not be renewed!"
    85         I (PKG="PS"),$$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q
    86         I '$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
    87 RN1     N PSIFN S PSIFN=$G(^OR(100,+IFN,4))
    88         I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q
    89         I DG="O RX" D  Q  ;Outpt Meds
    90         . N ORZ,ORD S ORZ=$L($T(RENEW^PSORENW),",")
    91         . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD)
    92         . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q
    93         . S X=+$P(X,U,2) D:X RESET^ORCACT03(+IFN,X)
    94         . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format
    95         I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q
    96         I ORDSTS=7,'$$IV^ORCACT03,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4)  S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q
    97         I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q
    98 RN2     I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D  Q:$D(ERROR)!'PSIFN
    99         . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q
    100         . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0
    101         . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q
    102         . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q
    103         . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q
    104         . S I=0 F  S I=+$O(^OR(100,DAD,2,I)) Q:I<1  D  Q:Y
    105         .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q  ;ignore NOW orders
    106         .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q
    107         .. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q
    108         ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q
    109         S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1  ;Ok
    110         I +X>1,$P(X,U,2) D RESET^ORCACT03(+IFN,+$P(X,U,2)) Q  ;replace OI
    111         S ERROR="This order may not be renewed: "_$P(X,U,2)
    112         Q
    113         ;
    114 XX      ; -- edit/change--
    115         I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q
    116         I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q
    117         I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q
    118         I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q
    119         I DG="TPN" S ERROR="TPN orders may not be changed!" Q
    120         I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q
    121         I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q
    122         I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q
    123         I $P(OR3,U,9) D  Q:$D(ERROR)
    124         . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW"  ;NOW ok
    125         . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0))  ;no conj=1dose/ok
    126         . S ERROR="Complex orders may not be changed!" Q
    127         I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q
    128         I $P(OR3,U,11)=2 D  Q:$D(ERROR)
    129         . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q
    130         . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q
    131         I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q
    132         I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
    133         I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
    134         Q
    135         ;
     1ORCACT01 ;SLC/MKB-Validate order actions cont ;5/6/04  20:39
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213**;Dec 17, 1997
     3 ;
     4ES ; -- sign [on chart]
     5 I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q
     6 N X I ACTSTS=11!(ACTSTS=10) D  Q:$L($G(ERROR))
     7 . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q
     8 . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q
     9 I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q
     10 S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q
     11 I X'=2 S ERROR="This order has been signed!" Q
     12 I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q
     13 I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q
     14 I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q
     15 I ACTION="RS" D  Q:$D(ERROR)  Q:$G(NATR)'="I"
     16 . Q:ACTSTS=11  Q:ACTSTS=10  ;unreleased - ok
     17 . S ERROR="This order has already been released!"
     18ES1 I PKG="PS" D  ;authorized to write meds?
     19 . N TYPE,OI,PSOI,DEAFLG,PKI
     20 . S X=$G(^VA(200,DUZ,"PS"))
     21 . I '$P(X,U) S ERROR="You are not authorized to sign med orders!" Q
     22 . I $P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q
     23 . Q:DG="IV RX"  Q:$P(ORA0,U,2)="DC"  ;don't need to ck DEA#
     24 . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE")
     25 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0
     26 . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$$OIDEA^PSSUTLA1(PSOI,TYPE)
     27 . I DEAFLG>0,'$L($$DEA^XUSER()) S ERROR="You must have a valid DEA# or VA# to sign this order!" Q
     28 . D PKISITE^ORWOR(.PKI)
     29 . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q
     30 Q
     31 ;
     32XFR ; -- transfer to inpt/outpt [IFN=order to be transferred]
     33 N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q
     34 I $$INACTIVE S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q
     35 S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS"))
     36 I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q
     37 I DG="O RX" D  Q:$L($G(ERROR))
     38 . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q
     39 . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN)
     40 Q
     41 ;
     42RW ; -- rewrite/copy
     43 I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q
     44 I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q
     45 I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q
     46 I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q
     47 I $$INACTIVE S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q
     48 I PKG="PS",'$$MEDOK S ERROR="This drug may not be ordered!" Q
     49 I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
     50 Q
     51 ;
     52RN ; -- renew
     53 I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q
     54 I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
     55 I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q
     56 I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q
     57 I PKG="OR" D  Q  ;Generic orders
     58 . I $$INACTIVE S ERROR="Orders for inactive orderables may not be renewed!" Q
     59 . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q
     60 . I "^1^2^6^7^"[(U_ORDSTS_U) Q  ;ok
     61 . S ERROR="This order may not be renewed!"
     62 I (PKG="PS"),$$INACTIVE S ERROR="Orders for inactive orderables may not be renewed!" Q
     63 I '$$MEDOK S ERROR="This drug may not be ordered!" Q
     64RN1 N PSIFN S PSIFN=$G(^OR(100,+IFN,4))
     65 I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q
     66 I DG="O RX" D  Q  ;Outpt Meds
     67 . N ORZ,ORD S ORZ=$L($T(RENEW^PSORENW),",")
     68 . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD)
     69 . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q
     70 . S X=+$P(X,U,2) D:X RESET(+IFN,X)
     71 . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format
     72 I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q
     73 I ORDSTS=7,'$$IV,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4)  S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q
     74 I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q
     75RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D  Q:$D(ERROR)!'PSIFN
     76 . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q
     77 . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0
     78 . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q
     79 . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q
     80 . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q
     81 . S I=0 F  S I=+$O(^OR(100,DAD,2,I)) Q:I<1  D  Q:Y
     82 .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q  ;ignore NOW orders
     83 .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q
     84 .. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q
     85 ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q
     86 S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1  ;Ok
     87 I +X>1,$P(X,U,2) D RESET(+IFN,+$P(X,U,2)) Q  ;replace OI
     88 S ERROR="This order may not be renewed: "_$P(X,U,2)
     89 Q
     90 ;
     91XX ; -- edit/change--
     92 I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q
     93 I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q
     94 I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q
     95 I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q
     96 I DG="TPN" S ERROR="TPN orders may not be changed!" Q
     97 I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q
     98 I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q
     99 I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q
     100 I $P(OR3,U,9) D  Q:$D(ERROR)
     101 . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW"  ;NOW ok
     102 . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0))  ;no conj=1dose/ok
     103 . S ERROR="Complex orders may not be changed!" Q
     104 I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q
     105 I $P(OR3,U,11)=2 D  Q:$D(ERROR)
     106 . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q
     107 . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q
     108 I $$INACTIVE S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q
     109 I PKG="PS",'$$MEDOK S ERROR="This drug may not be ordered!" Q
     110 I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
     111 Q
     112 ;
     113INACTIVE() ; -- Returns 1 or 0, if OI is now inactive
     114 N I,OI,PREOI,PREOIX,X,Y,ORNOW,DD,PSOI S Y=0,ORNOW=$$NOW^XLFDT
     115 S I=0 F  S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D  Q:Y
     116 . S OI=+$G(^OR(100,+IFN,4.5,I,1))
     117 . I OI S X=$G(^ORD(101.43,OI,.1)) I X,X<ORNOW S Y=1
     118 I Y,PKG="PS",DG'="IV RX" D  ;replacement OI?
     119 . S I=+$O(^OR(100,+IFN,4.5,"ID","DRUG",0)) Q:I'>0  ;first
     120 . S DD=+$G(^OR(100,+IFN,4.5,I,1)) Q:DD'>0  Q:$G(OI)'>0
     121 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2),X=$$ITEM^PSSUTIL1(PSOI,DD)
     122 . Q:X'>0  S X=+$O(^ORD(101.43,"ID",+$P(X,U,2)_";99PSP",0)) Q:X'>0
     123 . I $G(^ORD(101.43,X,.1)),$G(^(.1))<ORNOW Q  ;make sure new OI is active
     124 . S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0))
     125 . IF I D
     126 . . S PREOI=$G(^OR(100,+IFN,4.5,I,1))
     127 . . S PREOIX=$O(^OR(100,+IFN,.1,"B",PREOI,0))
     128 . . K ^OR(100,+IFN,.1,"B",PREOI,PREOIX)
     129 . . S ^OR(100,+IFN,.1,"B",X,PREOIX)=""
     130 . . S ^OR(100,+IFN,.1,PREOIX,0)=X
     131 . . S ^OR(100,+IFN,4.5,I,1)=X
     132 . . S Y=0 ;reset
     133 Q Y
     134 ;
     135MEDOK() ; -- Returns 1 or 0, if med OI usage=Y
     136 N Y,OI,ORPS,X S Y=1,X=$P(OR0,U,12)
     137 I (DG="SPLY")!(DG="O RX")!(DG="I RX")!(DG="UD RX") D
     138 . S OI=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0))
     139 . S OI=+$G(^OR(100,+IFN,4.5,OI,1))
     140 . S ORPS=$G(^ORD(101.43,OI,"PS"))
     141 I DG="SPLY",'$P(ORPS,U,5) S Y=0
     142 I DG="O RX",'(X="O"&$P(ORPS,U,2)),'(X="I"&($P(ORPS,U)=2)) S Y=0
     143 I DG="I RX"!(DG="UD RX"),'$P(ORPS,U) S Y=0
     144 I DG="IV RX" D
     145 . N I,X0,X1 S I=0
     146 . F  S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I<1  D  Q:Y<1
     147 .. S X0=$G(^OR(100,+IFN,4.5,I,0)),X1=+$G(^(1))
     148 .. I $P($G(^ORD(101.41,+$P(X0,U,2),0)),U)["ADDITIVE" S:'$P($G(^ORD(101.43,X1,"PS")),U,4) Y=0 Q
     149 .. S:'$P($G(^ORD(101.43,X1,"PS")),U,3) Y=0
     150 Q Y
     151 ;
     152IV() ; -- IV order, either Inpt or Fluid?
     153 I DG="IV RX" Q 1
     154 N I,OI,X S I=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0))
     155 S OI=+$G(^OR(100,IFN,4.5,+I,1)),X=$P($G(^ORD(101.43,+OI,"PS")),U)
     156 Q (X>1)
     157 ;
     158NTBG(ORIFN) ; -- Inpt order marked as 'Not to be Given'?
     159 N PSIFN,Y,ORI,ORCH S Y=""
     160 S PSIFN=$G(^OR(100,+ORIFN,4)) I PSIFN>0 Q $$ENNG^PSJORUT2(+ORVP,PSIFN)
     161 S ORI=0 F  S ORI=$O(^OR(100,+ORIFN,2,ORI)) Q:ORI'>0  S ORCH=+$G(^(ORI,0)),PSIFN=$G(^OR(100,ORCH,4)) I PSIFN>0 S Y=$$ENNG^PSJORUT2(+ORVP,PSIFN) Q:Y
     162 Q Y
     163 ;
     164RESET(IFN,NEWOI)   ; -- Update OI if changed before renewing
     165 Q:'$G(IFN)  Q:'$D(^OR(100,+IFN,0))  Q:'$G(NEWOI)
     166 N I,ORIT S ORIT=+$O(^ORD(101.43,"ID",NEWOI_";99PSP",0)) Q:ORIT'>0
     167 S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0))
     168 S:I ^OR(100,+IFN,4.5,I,1)=ORIT
     169 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT2.m

    r613 r623  
    1 ORCACT2 ;SLC/MKB-DC orders ; 03/27/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 DC      ; -- start here with:
    5         ;    ORNMBR = #,#,...,# of selected orders
    6         ;
    7         ;    OREBUILD defined on return if Orders tab needs to be rebuilt
    8         ;
    9         N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK=""
    10         S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
    11         I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ
    12         D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD
    13 DC1     F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR  Q:$D(ORQUIT)
    14         . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR))
    15         . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN
    16         . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q
    17         . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7)
    18         . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM)
    19         . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q
    20         . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q
    21         . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15)
    22         . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done
    23         . I (ORSTS=10)!(ORSTS=11) D UNREL Q  ;delete unreleased orders
    24         . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT)
    25 DC2     . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D  ;meds
    26         .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D
    27         ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)=""
    28         ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:"
    29         ... S I=0 F  S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1  S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X
    30         .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0
    31         .. W !,+ORY_" delayed order(s) for the same medication were found:"
    32         .. S ORJ=0 F  S ORJ=$O(ORY(ORJ)) Q:ORJ'>0  S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!,"  >> delayed until "_$P(ORV,U,2)
    33         .. I '$$OK(+ORY) W ! Q
    34         .. W !,"Orders not signed or released to the service will be deleted.",!
    35         .. S DIK="^OR(100,",DA=0 F  S DA=$O(ORY(DA)) Q:DA'>0  D
    36         ... N ORJ,ORSIG,STS,ORLKD
    37         ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q
    38         ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1)
    39         ... I STS'=10 S ORDC($$NXT)=DA Q  ;released - add to list
    40         ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))=""
    41         ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again
    42         G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX
    43 DC3     S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ
    44         S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR)
    45         I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3
    46         I ORCREATE D  I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ
    47         . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^"  ;S:ORNP=DUZ ORNATR="E"
    48         . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q
    49         . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1
    50         W ! W:'ORCREATE "Discontinuing orders ..."
    51         S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0)
    52         S (ORI,ORPRINT)=0 F  S ORI=$O(ORDC(ORI)) Q:ORI'>0  S ORIFN=ORDC(ORI) D
    53         . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA  D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q
    54         . ; release -> no order or ES req'd
    55         . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN)
    56         . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q
    57         . W !,$$ORDITEM(+ORIFN)_" not discontinued."
    58         . W:$L($P($G(ORERR),U,2)) !,"  >> "_$P(ORERR,U,2) W ! H 1
    59         W:ORCREATE "... discontinue order(s) placed." H 1
    60         I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT)
    61         S OREBUILD=1 ; rebuild orders list
    62 DCQ     D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif?
    63         D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
    64         S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed
    65         D:$D(OREVT) EVENT ;cancel any events?
    66         Q
    67         ;
    68 UNLOCK  ; -- Unlock orders in ORDC(ORI)=ORIFN
    69         N ORI,ORIFN S ORI=0
    70         F  S ORI=$O(ORDC(ORI)) Q:ORI'>0  S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN)
    71         Q
    72         ;
    73 OK(NUM) ; -- Ok to DC delayed order(s) too?
    74         N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
    75         S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? "
    76         S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs."
    77         W ! D ^DIR
    78         Q +Y
    79         ;
    80 NXT()   ; -- Return next available subscript in ORDC()
    81         N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1
    82         Q Y
    83         ;
    84 PRINT(NATR)     ; -- Ok to print order?
    85         N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1))
    86         S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5)
    87         Q Y
    88         ;
    89 ORDITEM(ID)     ; -- Returns order text
    90         ;N X,I,MORE S X=""
    91         ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"")
    92         ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0))
    93         ;I $L(X)>68 S X=$E(X,1,68),MORE=1
    94         ;S:MORE X=X_" ..."
    95         N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"")
    96         Q X
    97         ;
    98 SUBHDR(X)       ; -- Display subheader of order being acted on
    99         W !!,?(36-($L(X)\2)),"-- "_X_" --",!
    100         Q
    101         ;
    102 COMPLX  ; -- Ck for other child orders to be dc'd at same time
    103         N DAD,CHLD
    104         S DAD=0 F  S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1  D
    105         . S CHLD=0 F  S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1  D
    106         .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U)
    107         .. Q:$D(ORDC("DAD",DAD,CHLD))  S ORDC($$NXT)=CHLD
    108         Q
    109         ;
    110 DCREASON()      ; -- Returns Reason for DC
    111         N X,Y,DIC
    112         ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent
    113         S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B")
    114         S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: "
    115         D ^DIC
    116 DCRQ    S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature
    117         Q Y
    118         ;
    119 SET(ORDER,NATURE,REASON,TEXT,DCORIG)    ; -- Set DC Reason into 6-node
    120         Q:'$G(ORDER)  Q:'$D(^OR(100,+ORDER,0))  S ORDER=+ORDER
    121         I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0))
    122         S $P(^OR(100,ORDER,6),U,1,5)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT),$P(^(6),U,9)=$G(DCORIG)
    123         Q
    124         ;
    125 RESUME(ORDER)   ; -- Resume tray service when dc'ing tubefeeding ORDER?
    126         N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP)
    127         I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q
    128         Q:'X  I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!"
    129         S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? "
    130         S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO"
    131         D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1
    132         D:Y=1 RESUME^ORCSAVE(+ORDER)
    133         Q
    134         ;
    135 UNREL   ; -- Process unreleased/delayed order
    136         N ORA,ORA0,DA,DR,DIE
    137         S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0))
    138         ;S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0)
    139         ;W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.")
    140         K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D
    141         . S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)=""
    142         . I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE
    143         D UNLK1^ORX2(+ORIFN) S OREBUILD=1
    144         I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D  Q  ;new this session
    145         . W !,"This order will be deleted." H 1
    146         . D DELETE^ORCSAVE2(ORIFN),UNLK1^ORX2(+ORIFN) ;decrement lock again
    147         W !,"This order was not released and will be cancelled." H 1
    148         D CANCEL^ORCSAVE2(ORIFN):ORSTS=11,CLRDLY(+ORIFN):ORSTS=10
    149         Q
    150         ;
    151 CLRDLY(IFN)     ; -- [old Clear delayed fields] Cancel delayed [event]order
    152         N STS,ORX S IFN=+$G(IFN) Q:IFN'>0
    153         Q:'$D(^OR(100,IFN,0))  S STS=$P($G(^(3)),U,3)
    154         S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled"
    155         S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX
    156         D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13
    157         Q
    158         ;
    159 EVENT   ; -- Cancel event too?
    160         N EVT,X
    161         S EVT=0 F  S EVT=$O(OREVT(EVT)) Q:EVT<1  D  Q:$G(ORQUIT)
    162         . Q:$G(^ORE(100.2,EVT,1))  Q:'$$EMPTY^OREVNTX(EVT)  ;done or has orders
    163         . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders."
    164         . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? "
    165         . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it."
    166         . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q
    167         . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99)
    168         . W !,"   ... "_X_" event cancelled." H 1
    169         . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders
    170         Q
    171         ;
    172 DCD(IFN)        ; -- order discontinued already?
    173         N STS,Y,I S Y=0 I '$G(IFN) Q 1
    174         S STS=+$P($G(^OR(100,+IFN,3)),U,3)
    175         I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts
    176         ;look for existing DC action awaiting ES:
    177         S I=0 F  S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1  I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q
    178 DQ      Q Y
     1ORCACT2 ;SLC/MKB-DC orders ; 08 May 2002  2:12 PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265**;Dec 17, 1997;Build 17
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4DC ; -- start here with:
     5 ;    ORNMBR = #,#,...,# of selected orders
     6 ;
     7 ;    OREBUILD defined on return if Orders tab needs to be rebuilt
     8 ;
     9 N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK=""
     10 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
     11 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ
     12 D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD
     13DC1 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR  Q:$D(ORQUIT)
     14 . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR))
     15 . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN
     16 . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q
     17 . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7)
     18 . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM)
     19 . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q
     20 . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q
     21 . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15)
     22 . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done
     23 . I (ORSTS=10)!(ORSTS=11) D UNREL Q  ;delete unreleased orders
     24 . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT)
     25DC2 . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D  ;meds
     26 .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D
     27 ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)=""
     28 ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:"
     29 ... S I=0 F  S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1  S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X
     30 .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0
     31 .. W !,+ORY_" delayed order(s) for the same medication were found:"
     32 .. S ORJ=0 F  S ORJ=$O(ORY(ORJ)) Q:ORJ'>0  S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!,"  >> delayed until "_$P(ORV,U,2)
     33 .. I '$$OK(+ORY) W ! Q
     34 .. W !,"Orders not signed or released to the service will be deleted.",!
     35 .. S DIK="^OR(100,",DA=0 F  S DA=$O(ORY(DA)) Q:DA'>0  D
     36 ... N ORJ,ORSIG,STS,ORLKD
     37 ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q
     38 ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1)
     39 ... I STS'=10 S ORDC($$NXT)=DA Q  ;released - add to list
     40 ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))=""
     41 ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again
     42 G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX
     43DC3 S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ
     44 S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR)
     45 I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3
     46 I ORCREATE D  I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ
     47 . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^"  ;S:ORNP=DUZ ORNATR="E"
     48 . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q
     49 . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1
     50 W ! W:'ORCREATE "Discontinuing orders ..."
     51 S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0)
     52 S (ORI,ORPRINT)=0 F  S ORI=$O(ORDC(ORI)) Q:ORI'>0  S ORIFN=ORDC(ORI) D
     53 . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA  D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q
     54 . ; release -> no order or ES req'd
     55 . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN)
     56 . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q
     57 . W !,$$ORDITEM(+ORIFN)_" not discontinued."
     58 . W:$L($P($G(ORERR),U,2)) !,"  >> "_$P(ORERR,U,2) W ! H 1
     59 W:ORCREATE "... discontinue order(s) placed." H 1
     60 I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT)
     61 S OREBUILD=1 ; rebuild orders list
     62DCQ D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif?
     63 D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
     64 S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed
     65 D:$D(OREVT) EVENT ;cancel any events?
     66 Q
     67 ;
     68UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN
     69 N ORI,ORIFN S ORI=0
     70 F  S ORI=$O(ORDC(ORI)) Q:ORI'>0  S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN)
     71 Q
     72 ;
     73OK(NUM) ; -- Ok to DC delayed order(s) too?
     74 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
     75 S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? "
     76 S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs."
     77 W ! D ^DIR
     78 Q +Y
     79 ;
     80NXT() ; -- Return next available subscript in ORDC()
     81 N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1
     82 Q Y
     83 ;
     84PRINT(NATR) ; -- Ok to print order?
     85 N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1))
     86 S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5)
     87 Q Y
     88 ;
     89ORDITEM(ID) ; -- Returns order text
     90 ;N X,I,MORE S X=""
     91 ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"")
     92 ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0))
     93 ;I $L(X)>68 S X=$E(X,1,68),MORE=1
     94 ;S:MORE X=X_" ..."
     95 N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"")
     96 Q X
     97 ;
     98SUBHDR(X) ; -- Display subheader of order being acted on
     99 W !!,?(36-($L(X)\2)),"-- "_X_" --",!
     100 Q
     101 ;
     102COMPLX ; -- Ck for other child orders to be dc'd at same time
     103 N DAD,CHLD
     104 S DAD=0 F  S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1  D
     105 . S CHLD=0 F  S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1  D
     106 .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U)
     107 .. Q:$D(ORDC("DAD",DAD,CHLD))  S ORDC($$NXT)=CHLD
     108 Q
     109 ;
     110DCREASON() ; -- Returns Reason for DC
     111 N X,Y,DIC
     112 ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent
     113 S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B")
     114 S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: "  ;is referenced by DBIA #2058
     115 D ^DIC
     116DCRQ S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature
     117 Q Y
     118 ;
     119SET(ORDER,NATURE,REASON,TEXT) ; -- Set DC Reason into 6-node
     120 Q:'$G(ORDER)  Q:'$D(^OR(100,+ORDER,0))  S ORDER=+ORDER
     121 I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0))
     122 S ^OR(100,ORDER,6)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT)
     123 Q
     124 ;
     125RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER?
     126 N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP)
     127 I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q
     128 Q:'X  I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!"
     129 S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? "
     130 S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO"
     131 D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1
     132 D:Y=1 RESUME^ORCSAVE(+ORDER)
     133 Q
     134 ;
     135UNREL ; -- Process unreleased/delayed order
     136 N ORA,ORA0,ORDEL,DA,DR,DIE
     137 S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0))
     138 S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0)
     139 W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.") H 1 I ORDEL D
     140 . K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D
     141 .. S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)=""
     142 .. I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE
     143 . D DELETE^ORCSAVE2(ORIFN)
     144 D CLRDLY(+ORIFN):'ORDEL,UNLK1^ORX2(+ORIFN) S OREBUILD=1
     145 I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D UNLK1^ORX2(+ORIFN) ;decrement lock again
     146 Q
     147 ;
     148EVENT ; -- Cancel event too?
     149 N EVT,X
     150 S EVT=0 F  S EVT=$O(OREVT(EVT)) Q:EVT<1  D  Q:$G(ORQUIT)
     151 . Q:$G(^ORE(100.2,EVT,1))  Q:'$$EMPTY^OREVNTX(EVT)  ;done or has orders
     152 . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders."
     153 . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? "
     154 . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it."
     155 . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q
     156 . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99)
     157 . W !,"   ... "_X_" event cancelled." H 1
     158 . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders
     159 Q
     160 ;
     161DCD(IFN) ; -- order discontinued already?
     162 N STS,Y,I S Y=0 I '$G(IFN) Q 1
     163 S STS=+$P($G(^OR(100,+IFN,3)),U,3)
     164 I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts
     165 ;look for existing DC action awaiting ES:
     166 S I=0 F  S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1  I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q
     167DQ Q Y
     168 ;
     169CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order
     170 N STS,ORX S IFN=+$G(IFN) Q:IFN'>0
     171 Q:'$D(^OR(100,IFN,0))  S STS=$P($G(^(3)),U,3)
     172 S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled"
     173 S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX
     174 D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13
     175 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCB.m

    r613 r623  
    1 ORCB    ;SLC/MKB-Notifications followup for LMgr chart ;4/5/01  21:32
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,48,70,108,116,243**;Dec 17, 1997;Build 242
    3 EN(DFN,ORFLG,DGRP,DEL)  ; -- main entry point
    4         Q:'$G(DFN)  Q:'$G(ORFLG)
    5         N BEG,END D SLCT1^ORQPT
    6         S DGRP=$P($G(^ORD(100.98,+$G(DGRP),0)),U,3) S:'$L(DGRP) DGRP="ALL"
    7         S (BEG,END)="" I ORFLG=6 D  ;get BEG from XQAID for New Orders
    8         . S BEG=$P(XQAID,";",3) I BEG'?7N1".".6N!(BEG'<DT) S BEG="" Q
    9         . S BEG=$$FMADD^XLFDT(BEG,,,-5),END=$$NOW^XLFDT
    10         I ORFLG=9 D  ;get BEG from Current Admission
    11         . N ADM S ADM=+$G(^DPT(DFN,.105)) S:ADM ADM=+$P($G(^DGPM(ADM,0)),U)
    12         . S END=$$NOW^XLFDT,BEG=$S(ADM:ADM,1:$$FMADD^XLFDT(END,-30))
    13         S ^TMP("OR",$J,"ORDERS",0)="^^"_BEG_";"_END_";"_ORFLG_";"_DGRP_";L"
    14         D EN^VALM("ORCB NOTIFICATIONS")
    15         Q
    16         ;
    17 INIT    ; -- init variables and list array
    18         S ORTAB="ORDERS" D TAB^ORCHART("ORDERS",1)
    19         I VALMCNT=1,$G(^TMP("OR",$J,ORTAB,1,0))["No data available" D
    20         . N X,I S X="     No "_$S(ORFLG=5:"expiring",ORFLG=11:"unsigned",ORFLG=12:"flagged",9:"unverified",1:"new")_" orders found."
    21         . F I="ORDERS","CURRENT" S ^TMP("OR",$J,I,1,0)=$$LJ^XLFSTR(X,45)_"|"
    22         Q
    23         ;
    24 HELP    ; -- help code
    25         N X S VALMBCK=""
    26         W !!,"Enter the display numbers of the orders you wish to act on;"
    27         W !,"select either DT for a detailed listing of information about each"
    28         W !,"order, or the desired action.  Enter Q to exit."
    29         W !!,"Press <return> to continue ..." R X:DTIME
    30         Q
    31         ;
    32 PHDR    ; -- protocol menu header code
    33         N NUM,ORI,ORDEF,I,X K ORNMBR,OREBUILD
    34         S VALMSG=$$MSG^ORCHART D SHOW^VALM
    35         S NUM=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)
    36         S XQORM("#")=$O(^ORD(101,"B","ORCB ACTIONS",0))_"^1:"_NUM
    37         S ORI=$S(ORFLG=5:1,ORFLG=11:"2,3,4",ORFLG=12:"3,4,5,6,7",1:8)
    38         S ORDEF=$S(ORFLG=5:1,ORFLG=11:9,ORFLG=12:5,1:10)
    39         F I=1:1:$L(ORI,",") S X=$T(ACTIONS+$P(ORI,",",I)),XQORM("KEY",$P(X,";",3))=$O(^ORD(101,"B","ORC "_$P(X,";",4)_" ORDERS",0))_"^1"
    40         S XQORM("KEY","DT")=$O(^ORD(101,"B","ORC DETAILED DISPLAY",0))_"^1"
    41         I +$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)>0,XQORM("B")="Quit" S X=$T(ACTIONS+ORDEF),X=$P(X,";",4),XQORM("KEY",$P(X," "))=$O(^ORD(101,"B","ORC "_X_" ORDERS",0))_"^1",XQORM("B")=$$LOWER^VALM1(X)_" Orders" ; default action
    42         S:'$G(ORL) ORL=$$FINDLOC ; attempt to determine location from orders
    43         Q
    44         ;
    45 SELECT  ; -- process selected order(s)
    46         N MENU,XQORM,Y,ORNMBR,OREBUILD,ORY S VALMBCK=""
    47         S ORNMBR=$P(XQORNOD(0),"=",2) D SELECT^ORCHART(ORNMBR)
    48         S:'$G(ORFLG) ORFLG=$P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)
    49         S MENU=$S(ORFLG=5:"EXPIRING",ORFLG=11:"UNSIGNED",ORFLG=12:"FLAGGED",1:"NEW")
    50         S XQORM=$O(^ORD(101,"B","ORCB "_MENU_" MENU",0))_";ORD(101,"
    51         I 'XQORM W !!,"ERROR" H 2 G SQ
    52         S XQORM(0)="1AD",XQORM("A")="Select action: "
    53         W ! D EN^XQORM G:Y'>0 SQ M ORY=Y
    54         I $D(^ORD(101,+$P(ORY(1),U,2),20)) X ^(20) S VALMBCK="R"
    55         I $G(OREBUILD) D:ORFLG=12 UNFLAG D TAB^ORCHART(ORTAB,1) Q
    56 SQ      D DESELECT^ORCHART(ORNMBR)
    57         Q
    58         ;
    59 UNFLAG  ; -- Unflag orders
    60         N ORX,ORI,NUM,ORIFN,ORA,X
    61         S ORX=$P(ORY(1),U,3) Q:(ORX="Unflag")!(ORX="Detailed Display")
    62         F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D
    63         . S ORIFN=$P(^TMP("OR",$J,"CURRENT","IDX",NUM),U) Q:'ORIFN
    64         . S ORA=+$P(ORIFN,";",2),ORIFN=+ORIFN Q:'ORA
    65         . Q:'$D(^OR(100,ORIFN))  Q:(ORX="Edit")&($P(^(ORIFN,3),U,3)'=12)
    66         . S X=+$G(^OR(100,ORIFN,8,ORA,0)),$P(^(3),U)=0,$P(^(3),U,6,8)=X_U_DUZ_"^Unflagged by action" ; Unflag
    67         . S X=ORIFN_";"_ORA D MSG^ORCFLAG(X)
    68         Q
    69         ;
    70 EN1(ORIFN,ACTION)       ; -- entry point to display single order
    71         Q:'ORIFN  Q:'$D(^OR(100,ORIFN))
    72         Q:"^^NEW^RENEW^REPLACE^"'[(U_$G(ACTION)_U)
    73         S DFN=+$P(^OR(100,ORIFN,0),U,2) Q:'DFN
    74         S ^TMP("ORXPND",$J,0)=ORIFN_U_$G(ACTION)
    75         D EN1^ORCXPND(DFN,ORIFN)
    76         K ^TMP("ORXPND",$J),^TMP("OR",$J)
    77         Q
    78         ;
    79 NEW     ; -- Add new order as follow-up action
    80         N IFN,TYPE,ORIG,ORNP,ORPTLK S VALMBCK="" K ^TMP("ORNEW",$J)
    81         S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
    82         S ORNP=$$PROVIDER^ORCMENU1,VALMBCK="R" G:ORNP="^" NWQ
    83         I '$G(ORL) S ORL=$$LOCATION^ORCMENU1 G:ORL["^" NWQ
    84         S ORIG=+$P($G(^TMP("ORXPND",$J,0)),U),IFN=+$P($G(^OR(100,+ORIG,0)),U,5)
    85         G:'IFN NWQ S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4)
    86         ; If 2.5 order, use DG or PKG to get dlg
    87         D FULL^VALM1,ORDER^ORCMENU
    88         I $O(^TMP("ORNEW",$J,0)) D SIGN,NOTIF^ORCMENU2
    89         K ^TMP("ORNEW",$J) S VALMBCK="R"
    90 NWQ     D UNLOCK^ORX2(+ORVP)
    91         Q
    92         ;
    93 EDIT    ; -- Edit order as follow-up action
    94         N OREBUILD K ^TMP("ORNEW",$J)
    95         D EDIT^ORCACT I $G(OREBUILD) D
    96         . D SIGN,NOTIF^ORCMENU2
    97         . S $P(^TMP("ORXPND",$J,0),U,2)=""
    98         K ^TMP("ORNEW",$J) S VALMBCK="R"
    99         D UNLOCK^ORX2(+ORVP)
    100         Q
    101         ;
    102 RENEW   ; --Renew order as follow-up action
    103         N OREBUILD K ^TMP("ORNEW",$J)
    104         D RENEW^ORCACT I $G(OREBUILD) D
    105         . D SIGN,NOTIF^ORCMENU2
    106         . S $P(^TMP("ORXPND",$J,0),U,2)=""
    107         . K ^TMP("ORXPND",$J) D INIT^ORCXPND
    108         K ^TMP("ORNEW",$J) S VALMBCK="R"
    109         D UNLOCK^ORX2(+ORVP)
    110         Q
    111         ;
    112 SIGN    ; -- Sign new order
    113         N ORIFN,ORTAB,ORNMBR,CNT
    114         S ORTAB="NEW",(ORIFN,CNT)=0,ORNMBR=""
    115         F  S ORIFN=+$O(^TMP("ORNEW",$J,ORIFN)) Q:ORIFN'>0  S CNT=CNT+1,^TMP("OR",$J,"NEW","IDX",CNT)=ORIFN,ORNMBR=ORNMBR_CNT_","
    116         I CNT D EN^ORCSIGN K ^TMP("OR",$J,"NEW","IDX")
    117         Q
    118         ;
    119 EXIT    ; -- exit action
    120         I $P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)=12 D  ; flagged orders
    121         . Q:'$$GET^XPAR("ALL","ORPF AUTO UNFLAG")
    122         . N ORI,ORIFN,ORA,XQAKILL,ORN,ORUNF
    123         . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged"
    124         . S ORI=0 F  S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0  S ORIFN=$P(^(ORI),U),ORA=+$P(ORIFN,";",2) I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF D MSG^ORCFLAG(ORIFN) ; unflag
    125         . S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0))
    126         . S XQAKILL=$$XQAKILL^ORB3F1(ORN) D:$D(XQAID) DELETE^XQALERT
    127         D EXIT^ORCHART
    128         Q
    129         ;
    130 ACTIONS ;;KEY;NAME
    131         ;;RN;RENEW
    132         ;;$;SIGN
    133         ;;DC;DISCONTINUE
    134         ;;ED;CHANGE
    135         ;;UF;UNFLAG
    136         ;;HD;HOLD
    137         ;;RL;UNHOLD
    138         ;;VF;VERIFY
    139         ;;;SIGN ALL
    140         ;;;VERIFY ALL
    141         ;
    142 ALL     ; -- Select ALL orders
    143         N X,Y,DIR,MAX
    144         S MAX=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2),X="1-"_MAX,Y=""
    145         S DIR(0)="L^1:"_MAX,DIR("V")="" D:MAX ^DIR
    146         S ORNMBR=Y
    147         Q
    148         ;
    149 FINDLOC()       ; -- Loop through orders in alert to find assigned location
    150         N ORI,ORIFN,ORY S ORI=0,ORY=""
    151         F  S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0  S ORIFN=+^(ORI),ORX=$P($G(^OR(100,ORIFN,0)),U,10) S:ORY="" ORY=ORX I ORY'="",ORX'=ORY S ORY="" Q  ; ORY=location for all orders, or "" if different
    152         Q ORY
    153         ;
    154 DELETE  ; -- Delete current alert
    155         N %,%Y,X,Y,PRMT,XQAKILL S VALMBCK="",XQAKILL=1
    156         S PRMT="Your "_$S(ORFLG=5:"Expiring",ORFLG=11:"Unsigned",ORFLG=12:"Flagged",ORFLG=9:"Unverified",1:"New")_" Orders alert for "_$G(ORPNM)_" will be deleted!"
    157 D1      W !!,PRMT,!,"Are you sure" S %=2 D YN^DICN
    158         I (%<0)!(%=2) W !,"Nothing deleted." H 2 Q
    159         I %=0 D  G D1
    160         . W !!,"This action will delete the alert you are currently processing; the alert will",!,"disappear automatically when all orders have been acted on, but this action may",!,"be used to remove the alert if some orders are to be left unchanged."
    161         . W !,"Press <return> to continue ..." R X:DTIME
    162         W !,"Removing alert ..." D:$D(XQAID) DEL^ORB3FUP1(.Y,XQAID)
    163         I $G(Y)="TRUE" W " done." S VALMBCK="Q",DEL=1 H 2
    164         E  W " unable to delete alert." H 2
    165         Q
     1ORCB ;SLC/MKB-Notifications followup for LMgr chart ;4/5/01  21:32
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,48,70,108,116**;Dec 17, 1997
     3EN(DFN,ORFLG,DGRP,DEL) ; -- main entry point
     4 Q:'$G(DFN)  Q:'$G(ORFLG)
     5 N BEG,END D SLCT1^ORQPT
     6 S DGRP=$P($G(^ORD(100.98,+$G(DGRP),0)),U,3) S:'$L(DGRP) DGRP="ALL"
     7 S (BEG,END)="" I ORFLG=6 D  ;get BEG from XQAID for New Orders
     8 . S BEG=$P(XQAID,";",3) I BEG'?7N1".".6N!(BEG'<DT) S BEG="" Q
     9 . S BEG=$$FMADD^XLFDT(BEG,,,-5),END=$$NOW^XLFDT
     10 I ORFLG=9 D  ;get BEG from Current Admission
     11 . N ADM S ADM=+$G(^DPT(DFN,.105)) S:ADM ADM=+$P($G(^DGPM(ADM,0)),U)
     12 . S END=$$NOW^XLFDT,BEG=$S(ADM:ADM,1:$$FMADD^XLFDT(END,-30))
     13 S ^TMP("OR",$J,"ORDERS",0)="^^"_BEG_";"_END_";"_ORFLG_";"_DGRP_";L"
     14 D EN^VALM("ORCB NOTIFICATIONS")
     15 Q
     16 ;
     17INIT ; -- init variables and list array
     18 S ORTAB="ORDERS" D TAB^ORCHART("ORDERS",1)
     19 I VALMCNT=1,$G(^TMP("OR",$J,ORTAB,1,0))["No data available" D
     20 . N X,I S X="     No "_$S(ORFLG=5:"expiring",ORFLG=11:"unsigned",ORFLG=12:"flagged",9:"unverified",1:"new")_" orders found."
     21 . F I="ORDERS","CURRENT" S ^TMP("OR",$J,I,1,0)=$$LJ^XLFSTR(X,45)_"|"
     22 Q
     23 ;
     24HELP ; -- help code
     25 N X S VALMBCK=""
     26 W !!,"Enter the display numbers of the orders you wish to act on;"
     27 W !,"select either DT for a detailed listing of information about each"
     28 W !,"order, or the desired action.  Enter Q to exit."
     29 W !!,"Press <return> to continue ..." R X:DTIME
     30 Q
     31 ;
     32PHDR ; -- protocol menu header code
     33 N NUM,ORI,ORDEF,I,X K ORNMBR,OREBUILD
     34 S VALMSG=$$MSG^ORCHART D SHOW^VALM
     35 S NUM=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)
     36 S XQORM("#")=$O(^ORD(101,"B","ORCB ACTIONS",0))_"^1:"_NUM
     37 S ORI=$S(ORFLG=5:1,ORFLG=11:"2,3,4",ORFLG=12:"3,4,5,6,7",1:8)
     38 S ORDEF=$S(ORFLG=5:1,ORFLG=11:9,ORFLG=12:5,1:10)
     39 F I=1:1:$L(ORI,",") S X=$T(ACTIONS+$P(ORI,",",I)),XQORM("KEY",$P(X,";",3))=$O(^ORD(101,"B","ORC "_$P(X,";",4)_" ORDERS",0))_"^1"
     40 S XQORM("KEY","DT")=$O(^ORD(101,"B","ORC DETAILED DISPLAY",0))_"^1"
     41 I +$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)>0,XQORM("B")="Quit" S X=$T(ACTIONS+ORDEF),X=$P(X,";",4),XQORM("KEY",$P(X," "))=$O(^ORD(101,"B","ORC "_X_" ORDERS",0))_"^1",XQORM("B")=$$LOWER^VALM1(X)_" Orders" ; default action
     42 S:'$G(ORL) ORL=$$FINDLOC ; attempt to determine location from orders
     43 Q
     44 ;
     45SELECT ; -- process selected order(s)
     46 N MENU,XQORM,Y,ORNMBR,OREBUILD,ORY S VALMBCK=""
     47 S ORNMBR=$P(XQORNOD(0),"=",2) D SELECT^ORCHART(ORNMBR)
     48 S:'$G(ORFLG) ORFLG=$P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)
     49 S MENU=$S(ORFLG=5:"EXPIRING",ORFLG=11:"UNSIGNED",ORFLG=12:"FLAGGED",1:"NEW")
     50 S XQORM=$O(^ORD(101,"B","ORCB "_MENU_" MENU",0))_";ORD(101,"
     51 I 'XQORM W !!,"ERROR" H 2 G SQ
     52 S XQORM(0)="1AD",XQORM("A")="Select action: "
     53 W ! D EN^XQORM G:Y'>0 SQ M ORY=Y
     54 I $D(^ORD(101,+$P(ORY(1),U,2),20)) X ^(20) S VALMBCK="R"
     55 I $G(OREBUILD) D:ORFLG=12 UNFLAG D TAB^ORCHART(ORTAB,1) Q
     56SQ D DESELECT^ORCHART(ORNMBR)
     57 Q
     58 ;
     59UNFLAG ; -- Unflag orders
     60 N X,ORI,NUM,ORIFN,ORA
     61 S X=$P(ORY(1),U,3) Q:(X="Unflag")!(X="Detailed Display")
     62 F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D
     63 . S ORIFN=$P(^TMP("OR",$J,"CURRENT","IDX",NUM),U) Q:'ORIFN
     64 . S ORA=+$P(ORIFN,";",2),ORIFN=+ORIFN Q:'ORA
     65 . Q:'$D(^OR(100,ORIFN))  Q:(X="Edit")&($P(^(ORIFN,3),U,3)'=12)
     66 . S $P(^OR(100,ORIFN,8,ORA,3),U)=0 ; Unflag
     67 Q
     68 ;
     69EN1(ORIFN,ACTION) ; -- entry point to display single order
     70 Q:'ORIFN  Q:'$D(^OR(100,ORIFN))
     71 Q:"^^NEW^RENEW^REPLACE^"'[(U_$G(ACTION)_U)
     72 S DFN=+$P(^OR(100,ORIFN,0),U,2) Q:'DFN
     73 S ^TMP("ORXPND",$J,0)=ORIFN_U_$G(ACTION)
     74 D EN1^ORCXPND(DFN,ORIFN)
     75 K ^TMP("ORXPND",$J),^TMP("OR",$J)
     76 Q
     77 ;
     78NEW ; -- Add new order as follow-up action
     79 N IFN,TYPE,ORIG,ORNP,ORPTLK S VALMBCK="" K ^TMP("ORNEW",$J)
     80 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
     81 S ORNP=$$PROVIDER^ORCMENU1,VALMBCK="R" G:ORNP="^" NWQ
     82 I '$G(ORL) S ORL=$$LOCATION^ORCMENU1 G:ORL["^" NWQ
     83 S ORIG=+$P($G(^TMP("ORXPND",$J,0)),U),IFN=+$P($G(^OR(100,+ORIG,0)),U,5)
     84 G:'IFN NWQ S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4)
     85 ; If 2.5 order, use DG or PKG to get dlg
     86 D FULL^VALM1,ORDER^ORCMENU
     87 I $O(^TMP("ORNEW",$J,0)) D SIGN,NOTIF^ORCMENU2
     88 K ^TMP("ORNEW",$J) S VALMBCK="R"
     89NWQ D UNLOCK^ORX2(+ORVP)
     90 Q
     91 ;
     92EDIT ; -- Edit order as follow-up action
     93 N OREBUILD K ^TMP("ORNEW",$J)
     94 D EDIT^ORCACT I $G(OREBUILD) D
     95 . D SIGN,NOTIF^ORCMENU2
     96 . S $P(^TMP("ORXPND",$J,0),U,2)=""
     97 K ^TMP("ORNEW",$J) S VALMBCK="R"
     98 D UNLOCK^ORX2(+ORVP)
     99 Q
     100 ;
     101RENEW ; --Renew order as follow-up action
     102 N OREBUILD K ^TMP("ORNEW",$J)
     103 D RENEW^ORCACT I $G(OREBUILD) D
     104 . D SIGN,NOTIF^ORCMENU2
     105 . S $P(^TMP("ORXPND",$J,0),U,2)=""
     106 . K ^TMP("ORXPND",$J) D INIT^ORCXPND
     107 K ^TMP("ORNEW",$J) S VALMBCK="R"
     108 D UNLOCK^ORX2(+ORVP)
     109 Q
     110 ;
     111SIGN ; -- Sign new order
     112 N ORIFN,ORTAB,ORNMBR,CNT
     113 S ORTAB="NEW",(ORIFN,CNT)=0,ORNMBR=""
     114 F  S ORIFN=+$O(^TMP("ORNEW",$J,ORIFN)) Q:ORIFN'>0  S CNT=CNT+1,^TMP("OR",$J,"NEW","IDX",CNT)=ORIFN,ORNMBR=ORNMBR_CNT_","
     115 I CNT D EN^ORCSIGN K ^TMP("OR",$J,"NEW","IDX")
     116 Q
     117 ;
     118EXIT ; -- exit action
     119 I $P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)=12 D  ; flagged orders
     120 . Q:'$$GET^XPAR("ALL","ORPF AUTO UNFLAG")
     121 . N ORI,ORIFN,ORA,XQAKILL,ORN,ORUNF
     122 . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged"
     123 . S ORI=0 F  S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0  S ORIFN=$P(^(ORI),U),ORA=+$P(ORIFN,";",2) I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF ; unflag
     124 . S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0))
     125 . S XQAKILL=$$XQAKILL^ORB3F1(ORN) D:$D(XQAID) DELETE^XQALERT
     126 D EXIT^ORCHART
     127 Q
     128 ;
     129ACTIONS ;;KEY;NAME
     130 ;;RN;RENEW
     131 ;;$;SIGN
     132 ;;DC;DISCONTINUE
     133 ;;ED;CHANGE
     134 ;;UF;UNFLAG
     135 ;;HD;HOLD
     136 ;;RL;UNHOLD
     137 ;;VF;VERIFY
     138 ;;;SIGN ALL
     139 ;;;VERIFY ALL
     140 ;
     141ALL ; -- Select ALL orders
     142 N X,Y,DIR,MAX
     143 S MAX=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2),X="1-"_MAX,Y=""
     144 S DIR(0)="L^1:"_MAX,DIR("V")="" D:MAX ^DIR
     145 S ORNMBR=Y
     146 Q
     147 ;
     148FINDLOC() ; -- Loop through orders in alert to find assigned location
     149 N ORI,ORIFN,ORY S ORI=0,ORY=""
     150 F  S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0  S ORIFN=+^(ORI),ORX=$P($G(^OR(100,ORIFN,0)),U,10) S:ORY="" ORY=ORX I ORY'="",ORX'=ORY S ORY="" Q  ; ORY=location for all orders, or "" if different
     151 Q ORY
     152 ;
     153DELETE ; -- Delete current alert
     154 N %,%Y,X,Y,PRMT,XQAKILL S VALMBCK="",XQAKILL=1
     155 S PRMT="Your "_$S(ORFLG=5:"Expiring",ORFLG=11:"Unsigned",ORFLG=12:"Flagged",ORFLG=9:"Unverified",1:"New")_" Orders alert for "_$G(ORPNM)_" will be deleted!"
     156D1 W !!,PRMT,!,"Are you sure" S %=2 D YN^DICN
     157 I (%<0)!(%=2) W !,"Nothing deleted." H 2 Q
     158 I %=0 D  G D1
     159 . W !!,"This action will delete the alert you are currently processing; the alert will",!,"disappear automatically when all orders have been acted on, but this action may",!,"be used to remove the alert if some orders are to be left unchanged."
     160 . W !,"Press <return> to continue ..." R X:DTIME
     161 W !,"Removing alert ..." D:$D(XQAID) DEL^ORB3FUP1(.Y,XQAID)
     162 I $G(Y)="TRUE" W " done." S VALMBCK="Q",DEL=1 H 2
     163 E  W " unable to delete alert." H 2
     164 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCD.m

    r613 r623  
    1 ORCD    ; SLC/MKB - Order Dialog utilities ;12/15/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,243**;Dec 17,1997;Build 242
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 INPT()  ; -- Return 1 or 0, if patient/order sheet = inpatient
    5         N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0)
    6         I $G(OREVENT) D  ;override if delayed order
    7         . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0))
    8         . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent
    9         . S X=$P(X0,U,2) Q:X="M"  Q:X="O"  ;M/O keep current inpt status
    10         . S Y=$S(X="A":1,X="T":1,1:0)
    11         . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt
    12         . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt
    13         Q Y
    14         ;
    15 EXT(P,I,F)      ; -- Returns external value of ORDIALOG(Prompt,Instance)
    16         N TYPE,PARAM,FNUM,IENS,X,Y,J,Z
    17         S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2)
    18         S X=$G(ORDIALOG(P,I)) I X="" Q ""
    19         I TYPE="N",X<1 S X=0_+X I X="00" S X=0
    20         I "FNW"[TYPE Q X
    21         I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"")
    22         I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F)
    23         I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME
    24         I TYPE="P" D  Q Y
    25         . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2))
    26         . S IENS=+X_",",J=$L(PARAM,",") I J>2 F  S J=J-2 Q:J'>0  S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_","
    27         . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F)
    28         . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01)
    29         I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q
    30         Q $G(Y)
    31         ;
    32 FTDATE(X,F)     ; -- Returns free text form of date (i.e. TODAY)
    33         N D,T,P,Y I X="" Q ""
    34         S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts
    35         I "NOW"[X Q "NOW"
    36         I "NOON"[X Q "NOON"
    37         I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT"
    38         I (X="AM")!(X="NEXT") Q X_" Lab collection"
    39         I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time"
    40         I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D  Q $$FMTE^XLFDT(X,F)
    41         . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1
    42         S P=$S(D["+":"+",D["-":"-",1:"")
    43         I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW")
    44 FTD1    E  D
    45         . N OFFSET,NUM,UNIT
    46         . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D
    47         . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q
    48         . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY")
    49         . S:NUM>1 Y=Y_"S" ; plural
    50         . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO")
    51         . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO")
    52         . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT"
    53         I $L(T) S Y=Y_"@"_$$TIME(T)
    54         Q Y
    55         ;
    56 FTDHELP ; -- Displays ??-help for R-type prompts
    57         G R^ORCDLGH
    58         Q
    59         ;
    60 FTDCOMP(X1,X2,OPER)     ; -- Compares free text dates from prompts X1 & X2
    61         ;    Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true
    62         N X,Y,Y1,Y2,Z,%DT
    63         S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ??
    64         S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ??
    65         S Z="I "_Y1_OPER_Y2 X Z
    66         Q $T
    67         ;
    68 TIME(X) ; -- Returns 00:00 PM formatted time
    69         N Y,Z,%DT
    70         I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"")
    71         I "NOON"[X Q X
    72         I "MIDNIGHT"[X Q "MIDNIGHT"
    73         S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q ""
    74         S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3))
    75         Q Z
    76         ;
    77 VAL(TEXT,INST)  ; -- Returns internal form of TEXT's current value
    78         N I,X S X="" S:'$G(INST) INST=1
    79         I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match
    80         S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr
    81         Q $G(ORDIALOG(X,INST))
    82         ;
    83 ORDMSG(OI)      ; -- Display order message for orderable OI
    84         Q:'$O(^ORD(101.43,OI,8,0))  ; no order message
    85         N I S I=0 W !
    86         F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  W !,$G(^(I,0))
    87         W ! Q
    88         ;
    89 PTR(NAME)       ; -- Returns pointer to Dialog file for prompt NAME
    90         Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0))
    91         ;
    92 NMSP(PKG)       ; -- Returns package namespace from pointer
    93         N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1)
    94         S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR"
    95         Q Y
    96         ;
    97 GETQDLG(QIFN)   ; -- define ORDIALOG(PROMPT) for quick order QIFN
    98         S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG
    99         D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)")
    100         X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order
    101         Q
    102         ;
    103 DEFDLG(QDLG)    ; -- Returns default dialog for QDLG
    104         N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5)
    105         S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog
    106         I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4)
    107         Q DLG
    108         ;
    109 GETDLG(IFN)     ; -- define ORDIALOG(PROMPT) for dialog IFN
    110         N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP
    111         S SEQ=0 K ^TMP("ORWORD",$J)
    112         F  S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA  D
    113         . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6))
    114         . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR
    115         . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD
    116         . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3)
    117         . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"")
    118         . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13)
    119         . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples
    120         . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP)
    121         . S:$L(XHELP) ORD("??")=U_XHELP
    122         . S:$L(INDEX) ORD("D")=INDEX
    123         . S:$L(SCREEN) ORD("S")=SCREEN
    124         . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR
    125         . M ORDIALOG(PTR)=ORD
    126         Q
    127         ;
    128 GETDLG1(IFN)    ; -- basic ORDIALOG(PROMPT) for dialog IFN
    129         N SEQ,DA,PROMPT,PTR,WINCTRL
    130         K ^TMP("ORWORD",$J) S SEQ=0
    131         F  S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA  D
    132         . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR
    133         . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U)
    134         . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT)
    135         . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL
    136         . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2)
    137         Q
    138         ;
    139 GETORDER(ROOT,ARRAY)    ; -- retrieve order values from RESPONSES in ARRAY()
    140         N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG"
    141         I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN
    142         S ORI=0 F  S ORI=$O(@ROOT@(ORI)) Q:ORI'>0  S ID=$G(@ROOT@(ORI,0)) D
    143         . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1
    144         . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR
    145         . Q:'$D(ORDIALOG(PTR))  S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE)
    146         . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q
    147         . D RESTXT ;resolve objects
    148         . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")"
    149         . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST))
    150         . K @ORTXT
    151         Q
    152         ;
    153 RESTXT  ; -- resolve objects in text [from GETORDER+8]
    154         I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q  ;return text unresolved
    155         N ARRAY,PTR,INST
    156         D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2)))
    157         Q
    158         ;
    159 DUP(PROMPT,CURRENT)     ; -- Compare CURRENT instance of PROMPT for duplicates
    160         N X,Y,I
    161         S X=ORDIALOG(PROMPT,CURRENT),Y=0
    162         S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q
    163         Q Y
    164         ;
    165 LIST    ; -- Show contents of ORDIALOG(PROMPT,"LIST")
    166         N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM
    167         W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":")
    168 LIST1   N I,DONE,CNT S (I,CNT,DONE)=0
    169         F  S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0  D  Q:DONE
    170         . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q
    171         . W !,$J(I,6)_"   "_$P(ORDIALOG(PROMPT,"LIST",I),U,2)
    172         Q
    173         ;
    174 SETLIST ; -- Show allowable set of codes
    175         W !,"Choose from:"
    176 SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D
    177         . W !,?5,$P(X,":"),?15,$P(X,":",2)
    178         Q
    179         ;
    180 MORE()  ; -- show more?
    181         N X,Y,DIR
    182         S DIR(0)="EA",DIR("A")="    press <return> to continue or ^ to exit ..."
    183         D ^DIR
    184         Q +Y
    185         ;
    186 FIRST(P,I)      ; -- Returns 1 or 0, if current instance I is first of multiple
    187         Q '$O(ORDIALOG(P,I),-1)
    188         ;
    189 RECALL(P,I)     ; -- Returns first value for prompt P, instance I
    190         N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I))
    191         Q Y
     1ORCD ; SLC/MKB - Order Dialog utilities ;9/21/2005
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215**;Dec 17,1997
     3INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient
     4 N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0)
     5 I $G(OREVENT) D  ;override if delayed order
     6 . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0))
     7 . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent
     8 . S X=$P(X0,U,2) Q:X="M"  Q:X="O"  ;M/O keep current inpt status
     9 . S Y=$S(X="A":1,X="T":1,1:0)
     10 . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt
     11 . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt
     12 Q Y
     13 ;
     14EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance)
     15 N TYPE,PARAM,FNUM,IENS,X,Y,J,Z
     16 S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2)
     17 S X=$G(ORDIALOG(P,I)) I X="" Q ""
     18 I "FNW"[TYPE Q X
     19 I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"")
     20 I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F)
     21 I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME
     22 I TYPE="P" D  Q Y
     23 . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2))
     24 . S IENS=+X_",",J=$L(PARAM,",") I J>2 F  S J=J-2 Q:J'>0  S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_","
     25 . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F)
     26 . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01)
     27 I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q
     28 Q $G(Y)
     29 ;
     30FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY)
     31 N D,T,P,Y I X="" Q ""
     32 S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts
     33 I "NOW"[X Q "NOW"
     34 I "NOON"[X Q "NOON"
     35 I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT"
     36 I (X="AM")!(X="NEXT") Q X_" Lab collection"
     37 I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time"
     38 I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D  Q $$FMTE^XLFDT(X,F)
     39 . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1
     40 S P=$S(D["+":"+",D["-":"-",1:"")
     41 I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW")
     42FTD1 E  D
     43 . N OFFSET,NUM,UNIT
     44 . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D
     45 . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q
     46 . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY")
     47 . S:NUM>1 Y=Y_"S" ; plural
     48 . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO")
     49 . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO")
     50 . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT"
     51 I $L(T) S Y=Y_"@"_$$TIME(T)
     52 Q Y
     53 ;
     54FTDHELP ; -- Displays ??-help for R-type prompts
     55 G R^ORCDLGH
     56 Q
     57 ;
     58FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2
     59 ;    Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true
     60 N X,Y,Y1,Y2,Z,%DT
     61 S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ??
     62 S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ??
     63 S Z="I "_Y1_OPER_Y2 X Z
     64 Q $T
     65 ;
     66TIME(X) ; -- Returns 00:00 PM formatted time
     67 N Y,Z,%DT
     68 I "NOON"[X Q X
     69 I "MIDNIGHT"[X Q "MIDNIGHT"
     70 I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"")
     71 S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q ""
     72 S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3))
     73 Q Z
     74 ;
     75VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value
     76 N I,X S X="" S:'$G(INST) INST=1
     77 I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match
     78 S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr
     79 Q $G(ORDIALOG(X,INST))
     80 ;
     81ORDMSG(OI) ; -- Display order message for orderable OI
     82 Q:'$O(^ORD(101.43,OI,8,0))  ; no order message
     83 N I S I=0 W !
     84 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  W !,$G(^(I,0))
     85 W ! Q
     86 ;
     87PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME
     88 Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0))
     89 ;
     90NMSP(PKG) ; -- Returns package namespace from pointer
     91 N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1)
     92 S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR"
     93 Q Y
     94 ;
     95GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN
     96 S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG
     97 D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)")
     98 X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order
     99 Q
     100 ;
     101DEFDLG(QDLG) ; -- Returns default dialog for QDLG
     102 N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5)
     103 S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog
     104 I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4)
     105 Q DLG
     106 ;
     107GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN
     108 N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP
     109 S SEQ=0 K ^TMP("ORWORD",$J)
     110 F  S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA  D
     111 . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6))
     112 . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR
     113 . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD
     114 . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3)
     115 . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"")
     116 . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13)
     117 . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples
     118 . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP)
     119 . S:$L(XHELP) ORD("??")=U_XHELP
     120 . S:$L(INDEX) ORD("D")=INDEX
     121 . S:$L(SCREEN) ORD("S")=SCREEN
     122 . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR
     123 . M ORDIALOG(PTR)=ORD
     124 Q
     125 ;
     126GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN
     127 N SEQ,DA,PROMPT,PTR,WINCTRL
     128 K ^TMP("ORWORD",$J) S SEQ=0
     129 F  S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA  D
     130 . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR
     131 . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U)
     132 . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT)
     133 . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL
     134 . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2)
     135 Q
     136 ;
     137GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY()
     138 N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG"
     139 I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN
     140 S ORI=0 F  S ORI=$O(@ROOT@(ORI)) Q:ORI'>0  S ID=$G(@ROOT@(ORI,0)) D
     141 . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1
     142 . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR
     143 . Q:'$D(ORDIALOG(PTR))  S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE)
     144 . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q
     145 . D RESTXT ;resolve objects
     146 . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")"
     147 . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST))
     148 . K @ORTXT
     149 Q
     150 ;
     151RESTXT ; -- resolve objects in text [from GETORDER+8]
     152 I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q  ;return text unresolved
     153 N ARRAY,PTR,INST
     154 D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2)))
     155 Q
     156 ;
     157DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates
     158 N X,Y,I
     159 S X=ORDIALOG(PROMPT,CURRENT),Y=0
     160 S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q
     161 Q Y
     162 ;
     163LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST")
     164 N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM
     165 W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":")
     166LIST1 N I,DONE,CNT S (I,CNT,DONE)=0
     167 F  S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0  D  Q:DONE
     168 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q
     169 . W !,$J(I,6)_"   "_$P(ORDIALOG(PROMPT,"LIST",I),U,2)
     170 Q
     171 ;
     172SETLIST ; -- Show allowable set of codes
     173 W !,"Choose from:"
     174SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D
     175 . W !,?5,$P(X,":"),?15,$P(X,":",2)
     176 Q
     177 ;
     178MORE() ; -- show more?
     179 N X,Y,DIR
     180 S DIR(0)="EA",DIR("A")="    press <return> to continue or ^ to exit ..."
     181 D ^DIR
     182 Q +Y
     183 ;
     184FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple
     185 Q '$O(ORDIALOG(P,I),-1)
     186 ;
     187RECALL(P,I) ; -- Returns first value for prompt P, instance I
     188 N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I))
     189 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDFH1.m

    r613 r623  
    1 ORCDFH1 ;SLC/MKB,DKM - Utility functions for FH dialogs cont ;8/24/01  10:22
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**73,95,243**;Dec 17, 1997;Build 242
    3         ;
    4 RECENT  ; -- get 5 most recent diet orders
    5         N ORDT,ORIFN,ORIT,ORTXT,ORCURR,I,X,CNT,INDT S ORDT=$$NOW^XLFDT,CNT=0
    6         F  S ORDT=$O(^OR(100,"AW",ORVP,ORDG,ORDT),-1) Q:ORDT'>0  S ORIFN=0 D  Q:CNT'<5
    7         . F  S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,ORDT,ORIFN)) Q:ORIFN'>0  D  Q:CNT'<5
    8         .. S (ORIT,ORTXT)="" K ORCURR
    9         .. S:$P($G(^OR(100,+ORIFN,3)),U,3)=6 ORCURR=1 Q:'$O(^(.1,0))
    10         .. S I=0 F  S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0  S X=+$G(^(I,0)) I X D  ;**95
    11         ... S INDT=$G(^ORD(101.43,X,.1)) S ORIT=ORIT_$S($L(ORIT):";",1:"")_X,ORTXT=ORTXT_$S($L(ORTXT):", ",1:"")_$P($G(^ORD(101.43,X,0)),U)_$S(INDT&(INDT<$$NOW^XLFDT):" (*INACTIVE*)",1:"") ;**95
    12         .. Q:'ORIT  Q:'$L(ORTXT)  Q:ORTXT="NPO"
    13         .. S ORDIALOG(PROMPT,"LIST","D",ORIT)=ORIFN ;link oi string to order#
    14         .. Q:$G(ORCURR)  Q:+$G(ORDIALOG(PROMPT,"LIST","B",ORTXT))
    15         .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORIT_U_ORTXT
    16         .. S ORDIALOG(PROMPT,"LIST","B",ORTXT)=ORIT
    17         S ORDIALOG(PROMPT,"LIST")=CNT,ORDIALOG(PROMPT,"TOT")=0
    18         Q
    19         ;
    20 PTR(X)  ; -- Return ptr to Order Dialog file #101.41 for prompt X
    21         Q +$O(^ORD(101.41,"B","OR GTX "_X,0))
    22         ;
    23 EXP     ; -- Expand old order into instances
    24         N X,I,P,D S X=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(X)  Q:X'[";"
    25         S ORDIALOG(PROMPT,ORI)=+X,I=ORI ;1st mod only
    26         F P=2:1:$L(X,";") S D=$P(X,";",P),I=I+1,ORDIALOG(PROMPT,I)=D,ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1
    27         ;S:FIRST MAX=$L(X,";")
    28         Q
    29         ;
    30 VALID() ; -- Returns 1 or 0, if selected diet modification is valid
    31         N Y,NUM,I,TOTAL,OI
    32         S OI=$G(ORDIALOG(PROMPT,ORI)) I OI[";" D  Q Y
    33         .S Y=1 D EXP
    34         .I $$INACTIVE S Y=0 S ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-($L(OI,";")-1) F I=0:1:($L(OI,";")-1) K ORDIALOG(PROMPT,(I+ORI)) ;**95
    35         S Y=1,TOTAL=+$G(ORDIALOG(PROMPT,"TOT")),ORDIALOG(PROMPT,"MAX")=5,MAX=5
    36         I $$INACTIVE Q 0  ;**95
    37         ;S:FIRST MAX=$S($G(ORDIALOG(PROMPT,"LIST","D",OI)):1,1:5)
    38         S OI=$P($G(^ORD(101.43,+OI,0)),U)
    39         I (OI="REGULAR")!(OI="NPO") D  Q Y
    40         . I '$D(ORESET),TOTAL=0 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q  ; add first
    41         . I $G(ORESET),TOTAL'>1 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q  ; edit first
    42         . S Y=0 W $C(7),!,OI_" may not be ordered with other diets!"
    43         ;I $$DUP^ORCD(PROMPT,ORI) W $C(7),"This diet has already been selected!" Q 0  ;may delete after testing patch 95
    44         S NUM=$P($G(^ORD(101.43,+ORDIALOG(PROMPT,ORI),"FH")),U,2) ; precedence #
    45         S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  D  Q:Y'>0
    46         . Q:I=ORI  Q:$P($G(^ORD(101.43,+ORDIALOG(PROMPT,I),"FH")),U,2)'=NUM  ;ok
    47         . S Y=0 W $C(7),!,"This diet is not orderable with those already selected!",!
    48         Q Y
    49         ;
    50 PREV    ; -- Ck if previous diet being reordered
    51         N I,OI,IFN S OI="",I=0
    52         F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  S OI=OI_$S(OI:";",1:"")_ORDIALOG(PROMPT,I)
    53         S IFN=$S(OI:$G(ORDIALOG(PROMPT,"LIST","D",OI)),1:"")
    54         S:IFN ORDIALOG("PREV")=IFN K:'IFN ORDIALOG("PREV")
    55         Q
    56         ;
    57 CNV     ; -- Convert meal abbreviation to time in X [Input Xform]
    58         ; Expects X,PROMPT [also called from Entry Action, DO^ORWDXM2]
    59         N A1 S X=$$UP^XLFSTR(X),A1=$P(X,"@",2)
    60         I A1?1U,"BNE"[A1 D
    61         . I $G(ORTYPE)="Z" S DATATYPE="",Y=X Q  ;editor - ok
    62         . N TIMES S TIMES=$S($D(ORPARAM(2)):$P(ORPARAM(2),U,7,9),1:"6:00A^12:00P^6:00P")
    63         . S A1=$S(A1="B":$P(TIMES,U),A1="N":$P(TIMES,U,2),A1="E":$P(TIMES,U,3),1:A1)
    64         . S $P(X,"@",2)=A1
    65         Q
    66         ;
    67 LKUP    ; -- special lookup routine for diet modifications
    68         G:'$G(ORDIALOG(PROMPT,"LIST")) LKQ N OROOT,Z
    69         S:X=" " X=$$SPACE^ORCDLG2(DOMAIN) S OROOT=$NA(ORDIALOG(PROMPT,"LIST"))
    70         S Y=$$FIND^ORCDLG2(OROOT,X)
    71         I Y Q:X?1N  Q:'$$MORE(X,Y)  S Z=$$OK Q:Z  I Z="^" S Y="^" Q
    72 LKQ     D DIC^ORCDLG2
    73         Q
    74         ;
    75 MORE(XX,YY)     ; -- Returns 1 or 0, if more matches exist
    76         Q:$P(YY,U)[";" 1 ;multiple mods
    77         N CNT,XP,NOW S CNT=0,XP=XX,NOW=+$$NOW^XLFDT
    78         F  S XP=$O(^ORD(101.43,"S.DO",XP)) Q:$E(XP,1,$L(XX))'=XX  D  Q:CNT
    79         . N IFN S IFN=$O(^ORD(101.43,"S.DO",XP,0)) Q:IFN=+YY  ;same mod
    80         . I $G(^ORD(101.43,IFN,.1)),$G(^(.1))'>NOW Q  ;inactive
    81         . S CNT=CNT+1
    82         Q CNT
    83         ;
    84 OK()    ; -- Verify multiple diet mod selection
    85         N X,Y,DIR S DIR(0)="YA",DIR("A")="   ... OK? ",DIR("B")="Yes"
    86         S DIR("?")="Enter YES if you wish to re-order this entire diet, or NO to search for another single diet modification"
    87         D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
    88         Q Y
    89 INACTIVE()      ;Check for inactive/duplicate diets in single or multiple modifications ;**95
    90         N I,Y
    91         S Y=0
    92         S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:'+I  D
    93         .I $G(^ORD(101.43,ORDIALOG(PROMPT,I),.1)),^(.1)<$$NOW^XLFDT S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,I),0),U)," diet is INACTIVE." Q  ;Quit if inactive diet found in order
    94         F I=0:1:($L(OI,";")-1) I $$DUP^ORCD(PROMPT,(I+ORI)) S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,(I+ORI)),0),U)," diet has already been selected." ;check for duplicate orders
    95         Q Y
     1ORCDFH1 ;SLC/MKB,DKM - Utility functions for FH dialogs cont ;8/24/01  10:22
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**73,95**;Dec 17, 1997
     3 ;
     4RECENT ; -- get 5 most recent diet orders
     5 N ORDT,ORIFN,ORIT,ORTXT,ORCURR,I,X,CNT,INDT S ORDT=$$NOW^XLFDT,CNT=0
     6 F  S ORDT=$O(^OR(100,"AW",ORVP,ORDG,ORDT),-1) Q:ORDT'>0  S ORIFN=0 D  Q:CNT'<5
     7 . F  S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,ORDT,ORIFN)) Q:ORIFN'>0  D  Q:CNT'<5
     8 .. S (ORIT,ORTXT)="" K ORCURR
     9 .. S:$P($G(^OR(100,+ORIFN,3)),U,3)=6 ORCURR=1 Q:'$O(^(.1,0))
     10 .. S I=0 F  S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0  S X=+$G(^(I,0)) I X D  ;**95
     11 ... S INDT=$G(^ORD(101.43,X,.1)) S ORIT=ORIT_$S($L(ORIT):";",1:"")_X,ORTXT=ORTXT_$S($L(ORTXT):", ",1:"")_$P($G(^ORD(101.43,X,0)),U)_$S(INDT&(INDT<$$NOW^XLFDT):" (*INACTIVE*)",1:"") ;**95
     12 .. Q:'ORIT  Q:'$L(ORTXT)  Q:ORTXT="NPO"
     13 .. S ORDIALOG(PROMPT,"LIST","D",ORIT)=ORIFN ;link oi string to order#
     14 .. Q:$G(ORCURR)  Q:+$G(ORDIALOG(PROMPT,"LIST","B",ORTXT))
     15 .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORIT_U_ORTXT
     16 .. S ORDIALOG(PROMPT,"LIST","B",ORTXT)=ORIT
     17 S ORDIALOG(PROMPT,"LIST")=CNT,ORDIALOG(PROMPT,"TOT")=0
     18 Q
     19 ;
     20PTR(X) ; -- Return ptr to Order Dialog file #101.41 for prompt X
     21 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
     22 ;
     23EXP ; -- Expand old order into instances
     24 N X,I,P,D S X=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(X)  Q:X'[";"
     25 S ORDIALOG(PROMPT,ORI)=+X,I=ORI ;1st mod only
     26 F P=2:1:$L(X,";") S D=$P(X,";",P),I=I+1,ORDIALOG(PROMPT,I)=D,ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1
     27 ;S:FIRST MAX=$L(X,";")
     28 Q
     29 ;
     30VALID() ; -- Returns 1 or 0, if selected diet modification is valid
     31 N Y,NUM,I,TOTAL,OI
     32 S OI=$G(ORDIALOG(PROMPT,ORI)) I OI[";" D  Q Y
     33 .S Y=1 D EXP
     34 .I $$INACTIVE S Y=0 S ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-($L(OI,";")-1) F I=0:1:($L(OI,";")-1) K ORDIALOG(PROMPT,(I+ORI)) ;**95
     35 S Y=1,TOTAL=+$G(ORDIALOG(PROMPT,"TOT")),ORDIALOG(PROMPT,"MAX")=5,MAX=5
     36 I $$INACTIVE Q 0  ;**95
     37 ;S:FIRST MAX=$S($G(ORDIALOG(PROMPT,"LIST","D",OI)):1,1:5)
     38 S OI=$P($G(^ORD(101.43,+OI,0)),U)
     39 I (OI="REGULAR")!(OI="NPO") D  Q Y
     40 . I '$D(ORESET),TOTAL=0 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q  ; add first
     41 . I $G(ORESET),TOTAL'>1 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q  ; edit first
     42 . S Y=0 W $C(7),!,OI_" may not be ordered with other diets!"
     43 ;I $$DUP^ORCD(PROMPT,ORI) W $C(7),"This diet has already been selected!" Q 0  ;may delete after testing patch 95
     44 S NUM=$P($G(^ORD(101.43,+ORDIALOG(PROMPT,ORI),"FH")),U,2) ; precedence #
     45 S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  D  Q:Y'>0
     46 . Q:I=ORI  Q:$P($G(^ORD(101.43,+ORDIALOG(PROMPT,I),"FH")),U,2)'=NUM  ;ok
     47 . S Y=0 W $C(7),!,"This diet is not orderable with those already selected!",!
     48 Q Y
     49 ;
     50PREV ; -- Ck if previous diet being reordered
     51 N I,OI,IFN S OI="",I=0
     52 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  S OI=OI_$S(OI:";",1:"")_ORDIALOG(PROMPT,I)
     53 S IFN=$S(OI:$G(ORDIALOG(PROMPT,"LIST","D",OI)),1:"")
     54 S:IFN ORDIALOG("PREV")=IFN K:'IFN ORDIALOG("PREV")
     55 Q
     56 ;
     57CNV ; -- Convert meal abbreviation to time [Input Xform]
     58 N A1 S A1=$E($P(X,"@",2)) Q:'$L(A1)  ;not in form T@meal
     59 S A1=$S(A1="M":"11:59P",'$D(ORPARAM(2)):A1,A1="B":$P(ORPARAM(2),U,7),A1="N":$P(ORPARAM(2),U,8),A1="E":$P(ORPARAM(2),U,9),1:A1),$P(X,"@",2)=A1
     60 I $G(ORTYPE)="Z",A1?1U,"BNE"[A1 S DATATYPE="",Y=X ;editor
     61 Q
     62 ;
     63LKUP ; -- special lookup routine for diet modifications
     64 G:'$G(ORDIALOG(PROMPT,"LIST")) LKQ N OROOT,Z
     65 S:X=" " X=$$SPACE^ORCDLG2(DOMAIN) S OROOT=$NA(ORDIALOG(PROMPT,"LIST"))
     66 S Y=$$FIND^ORCDLG2(OROOT,X)
     67 I Y Q:X?1N  Q:'$$MORE(X,Y)  S Z=$$OK Q:Z  I Z="^" S Y="^" Q
     68LKQ D DIC^ORCDLG2
     69 Q
     70 ;
     71MORE(XX,YY) ; -- Returns 1 or 0, if more matches exist
     72 Q:$P(YY,U)[";" 1 ;multiple mods
     73 N CNT,XP,NOW S CNT=0,XP=XX,NOW=+$$NOW^XLFDT
     74 F  S XP=$O(^ORD(101.43,"S.DO",XP)) Q:$E(XP,1,$L(XX))'=XX  D  Q:CNT
     75 . N IFN S IFN=$O(^ORD(101.43,"S.DO",XP,0)) Q:IFN=+YY  ;same mod
     76 . I $G(^ORD(101.43,IFN,.1)),$G(^(.1))'>NOW Q  ;inactive
     77 . S CNT=CNT+1
     78 Q CNT
     79 ;
     80OK() ; -- Verify multiple diet mod selection
     81 N X,Y,DIR S DIR(0)="YA",DIR("A")="   ... OK? ",DIR("B")="Yes"
     82 S DIR("?")="Enter YES if you wish to re-order this entire diet, or NO to search for another single diet modification"
     83 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
     84 Q Y
     85INACTIVE() ;Check for inactive/duplicate diets in single or multiple modifications ;**95
     86 N I,Y
     87 S Y=0
     88 S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:'+I  D
     89 .I $G(^ORD(101.43,ORDIALOG(PROMPT,I),.1)),^(.1)<$$NOW^XLFDT S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,I),0),U)," diet is INACTIVE." Q  ;Quit if inactive diet found in order
     90 F I=0:1:($L(OI,";")-1) I $$DUP^ORCD(PROMPT,(I+ORI)) S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,(I+ORI)),0),U)," diet has already been selected." ;check for duplicate orders
     91 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m

    r613 r623  
    1 ORCDLG1 ; SLC/MKB - Order dialogs cont ;12/15/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110,243**;Dec 17, 1997;Build 242
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 EN(ITM,INST)    ; -- ask each ITM prompt where
    5         ;    ORDIALOG(PROMPT,#) = internal form of each response
    6         ;
    7         N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF
    8         S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3))
    9         S PROMPT=$P(ITEM,U,2) Q:'PROMPT  S:'$G(INST) INST=1
    10         S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9)
    11         S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0
    12         I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry
    13         I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1
    14         I '$D(ORDIALOG(PROMPT,INST)) D  ; get default value
    15         . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q
    16         . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7)
    17         . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95
    18         . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95
    19         . K VALIDEF ;**95
    20         I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept
    21 EN0     I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST))  G ENQ  ;ck child prompts
    22         . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))  N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95
    23         . S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D  Q:$G(ORQUIT)
    24         . . K VALIDEF ;110
    25         . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2)
    26         . . Q:$D(ORDIALOG(PRMT,INST))  ; already has a value
    27         . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7)
    28         . . I $D(Y) S VALIDEF=$$VALID ;**95
    29         . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q  ;**95
    30         . . D EN(DA,INST) ; ask
    31         I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask?
    32         I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ
    33         I $L(COND) X COND G:'$T ENQ ; failed condition
    34         M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2)
    35         I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ
    36 EN1     ; -- loop for multiples
    37         I '$O(ORDIALOG(PROMPT,0)) D  G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ
    38 M1      . D ADDMULT Q:$G(ORQUIT)
    39         . Q:'REQD!$O(ORDIALOG(PROMPT,0))  I FIRST,$G(SEQ)=1 S ORQUIT=1 Q
    40         . W $C(7),!!,$$REQUIRED,! G M1
    41         F  S ORX=$$SELECT Q:ORX=""  S:ORX="^" ORQUIT=1 Q:$G(ORQUIT)  D  Q:$G(DIROUT)
    42         . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0)
    43         . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT)  K ORQUIT,DIR("B")
    44         . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,!
    45 ENQ     X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action
    46         Q
    47         ;
    48 REQUIRED()      ; -- Required response message
    49         Q "A response is required!  Enter '^' to quit."
    50         ;
    51 SELECT()        ; -- select instance of multiple to edit
    52         N DIR,X,Y,CNT,I,MAX,TOTAL,DONE
    53         S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT"))
    54         S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
    55         S (I,CNT)=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children
    56         I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>"
    57         S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: "
    58         S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change"
    59 S1      D ^DIR I $D(DTOUT)!(Y="^") Q "^"
    60         I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1
    61         I Y="" Q Y
    62         Q CNT(Y)
    63         ;
    64 ONLY(I) ; -- I the only instance?
    65         N J,Z S J=0,Z=1
    66         F  S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0  I J'=I S Z=0 Q
    67         Q Z
    68         ;
    69 ADDMULT ; -- add new instances of multiple
    70         N DONE,LAST,INST,MAX,ANOTHER
    71         S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q
    72         S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another "
    73         S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A")
    74         F  D  Q:$G(ORQUIT)!($G(DONE))  I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT"))
    75         . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1
    76         . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q
    77         . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A")
    78         Q
    79         ;
    80 ONE(ORI,REQD)   ; -- ask single-valued prompt
    81         N DONE,ORESET
    82         S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI)
    83         F  D  Q:$G(DONE)  I $G(ORQUIT) Q:FIRST  Q:'REQD!$D(ORDIALOG(PROMPT,ORI))  S FIRST=$$DONE^ORCDLG2 Q:FIRST  K ORQUIT
    84         . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q
    85         . I X="" S DONE=1 Q
    86         . I X?1"^".E D UJUMP Q
    87         . I X="@" D DELETE Q
    88         . I $E(DIR(0))="N",Y<1,$E(Y,1,2)'="0." S Y=0_Y
    89         . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1
    90         . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q  ; validate - if failed, K DONE to reask
    91         . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q
    92         Q
    93         ;
    94 CHILDREN(PARENT,INST)   ; -- ask child prompts
    95         N SEQ,DA,ORQUIT S SEQ=0
    96         F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT)
    97         K:$G(ORQUIT) DONE ; reask parent
    98         Q
    99         ;
    100 RESET   ; -- Reset original prompt value
    101         K ORDIALOG(PROMPT,ORI)
    102         S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET
    103         Q
    104         ;
    105 UJUMP   ; -- ^-jump
    106         N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT
    107         I $G(NOJUMP) W $C(7),"  ^-jumping not allowed!" Q
    108         S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q
    109         I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ
    110         S CNT=0,P=XP F  S P=$O(ORDIALOG("B",P)) Q:P=""  Q:$E(P,1,$L(XP))'=XP  Q:FIRST&(+ORDIALOG("B",P)'<SEQ)  S CNT=CNT+1,MATCH(CNT)=+ORDIALOG("B",P)_U_P ; =SEQ^TEXT
    111         I 'CNT W $C(7),"  ??" Q
    112         I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ
    113         F I=1:1:CNT S DIR("A",I)=I_"  "_$P(MATCH(I),U,2)
    114         S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
    115         S DIR("?")="Select the field you wish to jump to, by number"
    116         D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q
    117         S NEWSEQ=+MATCH(Y)
    118 UJQ     I FIRST,NEWSEQ'<SEQ W $C(7),"  ^-jumping ahead not allowed now!" Q
    119         S SEQ=NEWSEQ-.01,DONE=1
    120         Q
    121         ;
    122 DELETE  ; -- delete response
    123         I '$D(DIR("B")) W $C(7),"  ??" Q
    124         Q:'$$SURE  S DONE=1
    125         K ORDIALOG(PROMPT,ORI),DIR("B")
    126         S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1
    127         I $D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI)
    128         Q
    129         ;
    130 DELCHILD(PARENT,INST)   ; -- delete child prompts
    131         N SEQ,DA,PTR S:'$G(INST) INST=1
    132         S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST)
    133         Q
    134         ;
    135 SURE()  ; -- sure you want to delete?
    136         N X,Y,DIR
    137         S DIR(0)="YA",DIR("A")="  Are you sure you want to delete this value? "
    138         S DIR("B")="NO" W $C(7) D ^DIR
    139         S:$D(DTOUT) Y="^"
    140         Q Y
    141         ;
    142 VALID() ;Check to see if default value is valid.  Returns 0 or 1
    143         ;Entire section added in patch 95
    144         N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG
    145         I Y="" Q 1 ;If default is null allow to pass ;110
    146         S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call
    147         S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done
    148         I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location
    149         I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up
    150         I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking
    151         S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call
    152         I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input
    153         I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly
    154         I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo
    155         I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes
    156         D ^DIR
    157         I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid
    158         I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid
    159         I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid
    160         I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid
    161         I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid
    162         I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid
    163         I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)<MIN!($L(Y)>MAX) Q 0 ;Free text and not within valid limit
    164         I $G(RTYPE) S Y=ORIG ;Set y back to relative date
    165         I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110
    166         Q 1 ;Must be valid
     1ORCDLG1 ; SLC/MKB - Order dialogs cont ;11/21/01  08:03
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110**;Dec 17, 1997
     3EN(ITM,INST) ; -- ask each ITM prompt where
     4 ;    ORDIALOG(PROMPT,#) = internal form of each response
     5 ;
     6 N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF
     7 S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3))
     8 S PROMPT=$P(ITEM,U,2) Q:'PROMPT  S:'$G(INST) INST=1
     9 S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9)
     10 S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0
     11 I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry
     12 I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1
     13 I '$D(ORDIALOG(PROMPT,INST)) D  ; get default value
     14 . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q
     15 . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7)
     16 . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95
     17 . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95
     18 . K VALIDEF ;**95
     19 I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept
     20EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST))  G ENQ  ;ck child prompts
     21 . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))  N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95
     22 . S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D  Q:$G(ORQUIT)
     23 . . K VALIDEF ;110
     24 . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2)
     25 . . Q:$D(ORDIALOG(PRMT,INST))  ; already has a value
     26 . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7)
     27 . . I $D(Y) S VALIDEF=$$VALID ;**95
     28 . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q  ;**95
     29 . . D EN(DA,INST) ; ask
     30 I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask?
     31 I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ
     32 I $L(COND) X COND G:'$T ENQ ; failed condition
     33 M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2)
     34 I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ
     35EN1 ; -- loop for multiples
     36 I '$O(ORDIALOG(PROMPT,0)) D  G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ
     37M1 . D ADDMULT Q:$G(ORQUIT)
     38 . Q:'REQD!$O(ORDIALOG(PROMPT,0))  I FIRST,$G(SEQ)=1 S ORQUIT=1 Q
     39 . W $C(7),!!,$$REQUIRED,! G M1
     40 F  S ORX=$$SELECT Q:ORX=""  S:ORX="^" ORQUIT=1 Q:$G(ORQUIT)  D  Q:$G(DIROUT)
     41 . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0)
     42 . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT)  K ORQUIT,DIR("B")
     43 . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,!
     44ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action
     45 Q
     46 ;
     47REQUIRED() ; -- Required response message
     48 Q "A response is required!  Enter '^' to quit."
     49 ;
     50SELECT() ; -- select instance of multiple to edit
     51 N DIR,X,Y,CNT,I,MAX,TOTAL,DONE
     52 S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT"))
     53 S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
     54 S (I,CNT)=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children
     55 I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>"
     56 S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: "
     57 S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change"
     58S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^"
     59 I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1
     60 I Y="" Q Y
     61 Q CNT(Y)
     62 ;
     63ONLY(I) ; -- I the only instance?
     64 N J,Z S J=0,Z=1
     65 F  S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0  I J'=I S Z=0 Q
     66 Q Z
     67 ;
     68ADDMULT ; -- add new instances of multiple
     69 N DONE,LAST,INST,MAX,ANOTHER
     70 S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q
     71 S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another "
     72 S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A")
     73 F  D  Q:$G(ORQUIT)!($G(DONE))  I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT"))
     74 . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1
     75 . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q
     76 . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A")
     77 Q
     78 ;
     79ONE(ORI,REQD) ; -- ask single-valued prompt
     80 N DONE,ORESET
     81 S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI)
     82 F  D  Q:$G(DONE)  I $G(ORQUIT) Q:FIRST  Q:'REQD!$D(ORDIALOG(PROMPT,ORI))  S FIRST=$$DONE^ORCDLG2 Q:FIRST  K ORQUIT
     83 . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q
     84 . I X="" S DONE=1 Q
     85 . I X?1"^".E D UJUMP Q
     86 . I X="@" D DELETE Q
     87 . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1
     88 . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q  ; validate - if failed, K DONE to reask
     89 . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q
     90 Q
     91 ;
     92CHILDREN(PARENT,INST) ; -- ask child prompts
     93 N SEQ,DA,ORQUIT S SEQ=0
     94 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT)
     95 K:$G(ORQUIT) DONE ; reask parent
     96 Q
     97 ;
     98RESET ; -- Reset original prompt value
     99 K ORDIALOG(PROMPT,ORI)
     100 S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET
     101 Q
     102 ;
     103UJUMP ; -- ^-jump
     104 N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT
     105 I $G(NOJUMP) W $C(7),"  ^-jumping not allowed!" Q
     106 S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q
     107 I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ
     108 S CNT=0,P=XP F  S P=$O(ORDIALOG("B",P)) Q:P=""  Q:$E(P,1,$L(XP))'=XP  Q:FIRST&(+ORDIALOG("B",P)'<SEQ)  S CNT=CNT+1,MATCH(CNT)=+ORDIALOG("B",P)_U_P ; =SEQ^TEXT
     109 I 'CNT W $C(7),"  ??" Q
     110 I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ
     111 F I=1:1:CNT S DIR("A",I)=I_"  "_$P(MATCH(I),U,2)
     112 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
     113 S DIR("?")="Select the field you wish to jump to, by number"
     114 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q
     115 S NEWSEQ=+MATCH(Y)
     116UJQ I FIRST,NEWSEQ'<SEQ W $C(7),"  ^-jumping ahead not allowed now!" Q
     117 S SEQ=NEWSEQ-.01,DONE=1
     118 Q
     119 ;
     120DELETE ; -- delete response
     121 I '$D(DIR("B")) W $C(7),"  ??" Q
     122 Q:'$$SURE  S DONE=1
     123 K ORDIALOG(PROMPT,ORI),DIR("B")
     124 S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1
     125 I $D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI)
     126 Q
     127 ;
     128DELCHILD(PARENT,INST) ; -- delete child prompts
     129 N SEQ,DA,PTR S:'$G(INST) INST=1
     130 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST)
     131 Q
     132 ;
     133SURE() ; -- sure you want to delete?
     134 N X,Y,DIR
     135 S DIR(0)="YA",DIR("A")="  Are you sure you want to delete this value? "
     136 S DIR("B")="NO" W $C(7) D ^DIR
     137 S:$D(DTOUT) Y="^"
     138 Q Y
     139 ;
     140VALID() ;Check to see if default value is valid.  Returns 0 or 1
     141 ;Entire section added in patch 95
     142 N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG
     143 I Y="" Q 1 ;If default is null allow to pass ;110
     144 S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call
     145 S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done
     146 I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location
     147 I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up
     148 I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking
     149 S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call
     150 I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input
     151 I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly
     152 I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo
     153 I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes
     154 D ^DIR
     155 I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid
     156 I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid
     157 I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid
     158 I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid
     159 I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid
     160 I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid
     161 I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)<MIN!($L(Y)>MAX) Q 0 ;Free text and not within valid limit
     162 I $G(RTYPE) S Y=ORIG ;Set y back to relative date
     163 I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110
     164 Q 1 ;Must be valid

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG2.m

    r613 r623  
    1 ORCDLG2 ;SLC/MKB-Order dialogs cont ;10/12/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 DIR     ; -- ^DIR read of X, returns Y
    5         N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y
    6         S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99)
    7         S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn
    8         S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99)
    9 DIR1    I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q
    10         I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT)
    11         I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X)  W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1
    12         I X="@" Q:'REQD  W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1
    13         I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q
    14         I X?1"?".E D  G DIR1
    15         . N XHELP
    16         . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH"))
    17         . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP
    18         . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE)
    19         . I $L(DIR("?"))<80 W !,DIR("?"),!
    20         . E  D  W !
    21         . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W")
    22         . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0))
    23         I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1
    24         I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0  D ERR G DIR1
    25         I $G(ORDIALOG(PROMPT,"LIST")) D  Q:$L(Y)  I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1
    26         . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")"
    27         . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN)
    28         . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q
    29         . ; S ORX=$$EXPLIST(X) F  S Y(Y+1)=$$FIND
    30         I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1
    31         I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1
    32         I "^F^N^S^Y^"[(U_DATATYPE_U) D  I $G(DDER) D ERR G DIR1 ;JEH 'REPL was  checked
    33         . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's
    34         . S DIR("V")="" D ^DIR ; silent
    35         Q
    36         ;
    37 ERR     ; -- show help msg on error
    38         W:$D(DIR("?")) $C(7),!,DIR("?"),!
    39         Q
    40         ;
    41 FIND(LIST,X)    ; -- find value X in LIST(#) or LIST("B",name)
    42         N Y,XP,CNT,MATCH,I,DIR
    43         S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X)
    44         S CNT=0,XP="" F  S XP=$O(@LIST@("B",XP)) Q:XP=""  I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP
    45         I X=+X!(X?1"0."1.N) S Y=$G(@LIST@(X)) I $L(Y) W "   "_$P(Y,U,2) G:$$OK FQ S X="" W "   " ;force entire text to echo if CNT=1
    46         I 'CNT S Y="" G FQ
    47         I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ
    48         S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
    49         S DIR("?")="Select the desired value, by number"
    50         D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ
    51         S Y=MATCH(Y) W "  "_$P(Y,U,2)
    52 FQ      D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV
    53         Q Y
    54         ;
    55 OK()    ; -- Return 1 or 0, if selected item is correct
    56         N X,Y,DIR I CNT'>0 Q 1 ;no other matches
    57         S DIR(0)="YA",DIR("A")="   ...OK? ",DIR("B")="YES"
    58         S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list"
    59         D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
    60         Q +Y
    61         ;
    62 DIC     ; -- ^DIC lookup on X, return Y
    63         N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2)
    64         S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file?
    65         I X=" ",ORDITM D SPBAR W $S(Y>0:"   "_X,1:$C(7)_"  ??") Q
    66         I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q
    67         I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q  ; default
    68         S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC
    69         S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S")
    70         S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
    71         S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) ""   (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF
    72         S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^")
    73         I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M"
    74         D @ORDIC,SETDISV:Y&ORDITM
    75         I DIC(0)["S",X'=$P(Y,"^",2) W "  ",$P(Y,"^",2)
    76         Q
    77         ;
    78 SPACE(FILE)     ; -- Resolve spbar-return for ptrs
    79         N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":")
    80         I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X
    81         S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT))
    82         S:Y X=$P(@(ROOT_Y_",0)"),U)
    83         Q X
    84         ;
    85 SPBAR   ; -- Resolve spbar-return for #101.43
    86         N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^")
    87         F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q
    88         Q:'$L(SDX)  S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1)
    89         S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1
    90         Q
    91         ;
    92 SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43
    93         N SDX,I Q:'$L($P(Y,U,2))
    94         S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S."
    95         F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q
    96         Q:'$L(SDX)  S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2)
    97         Q
    98         ;
    99 DT      ; -- %DT validation on X, return Y
    100         N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X)
    101         I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed
    102         I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed
    103         D ^%DT Q:Y'>0
    104         I $G(BEG) D  Q:Y<0
    105         . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only
    106         . I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q
    107         I $G(END) D  Q:Y<0
    108         . I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only
    109         . I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q
    110         I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text
    111         Q
    112 DT1     S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT"
    113         I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q
    114         S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2)
    115         S Y=$E(D) I "VT"'[Y S Y=-1 Q
    116         I (D["+")!(D["-") D  Q:Y<0
    117         . N SIGN,OFFSET,X1,X2
    118         . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q
    119         . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q
    120         . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g.
    121         I '$L(T)&(DOMAIN["R") S Y=-1 Q  ; time missing, required
    122         I $L(T) D  I '$D(T) S Y=-1 Q
    123         . I '(DOMAIN["T"!(DOMAIN["R")) K T Q  ; time prohibited
    124         . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q
    125         . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T))
    126         S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error
    127         Q
    128         ;
    129 RELDT(X)        ; -- Returns 1 or 0, if X is relative date
    130         N Y S X=$G(X)
    131         I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1
    132         E  S Y=0
    133         Q Y
    134         ;
    135 FMDT(X) ; -- Return FM form of date X
    136         N Y,%DT S %DT="T" D ^%DT
    137         Q Y
    138         ;
    139 WP      ; -- edit WP field
    140         N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT,LCNT,UPCARR
    141         S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1
    142         S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ)
    143         I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8)
    144         I 'ORLINEDT,'REQD,'$$EDITWP Q  ;94
    145 WP1     W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":")
    146         D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q
    147         I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q
    148         I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q  ;empty
    149         S LCNT="",UPCARR=0
    150         F  S LCNT=$O(^TMP("ORWORD",$J,PROMPT,INST,LCNT)) Q:LCNT=""!(UPCARR=1)  D
    151         .I LCNT>0,$G(^TMP("ORWORD",$J,PROMPT,INST,LCNT,0))[U S UPCARR=1
    152         I UPCARR=1 W !!,"An ""^"" is not allowed in a word processing field." G:'$$DONE WP1 S ORQUIT=1 Q
    153         S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1
    154         I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE))  G WP1
    155         Q
    156         ;
    157 EDITWP()        ; -- Want to edit WP field?
    158         N X,Y,%,%Y
    159         W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST))
    160         I 'Y,REQD Q 1 ; no data, req'd
    161         W:'Y !,"  No existing text",! I Y D  ; show comments
    162         . N X,DIWL,DIWR,DIWF,ORI
    163         . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W")
    164         . S ORI=0 F  S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0  S X=$G(^(ORI,0)) D:$L(X) ^DIWP
    165         . D ^DIWW
    166 ED1     S %=$S($D(OREDIT):1,1:2) W "  Edit" D YN^DICN
    167         I %=0 W !,"  Enter 'YES' if you wish to go into the editor.",!,"  Enter 'NO' if you do not wish to edit at this time.",! G ED1
    168         S Y=$S(%<0:"^",%=2:0,1:1)
    169         Q Y
    170         ;
    171 LINEDTR(USER)   ; -- Returns 1 or 0, if user's editor will be LineEd
    172         N X,Y
    173         S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1
    174         E  S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1
    175         Q Y
    176         ;
    177 RETURN()        ; -- press return to cont
    178         N X W !,"Press <return> to continue ..." R X:DTIME
    179         Q ""
    180         ;
    181 DONE()  ; -- Done editing?
    182         N DIR,X,Y
    183         S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO"
    184         S DIR("?")="Enter YES to exit this order, or NO to continue editing"
    185         D ^DIR
    186         Q +Y
    187         ;
    188 HELP(TYPE)      ; -- Returns default help msg for TYPE prompt
    189         N Y S Y=""
    190         I TYPE="D" S Y="Enter a date[/time]."
    191         I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW."
    192         I TYPE="F" S Y="Enter a string of text."
    193         I TYPE="N" S Y="Enter a number."
    194         I TYPE="S" S Y="Enter an item from the list."
    195         I TYPE="Y" S Y="Enter YES or NO."
    196         I TYPE="P" S Y="Enter an item from the file."
    197         I TYPE="W" S Y=""
    198         Q Y
     1ORCDLG2 ;SLC/MKB-Order dialogs cont ;3/13/01  11:16
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94**;Dec 17, 1997
     3DIR ; -- ^DIR read of X, returns Y
     4 N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y
     5 S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99)
     6 S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn
     7 S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99)
     8DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q
     9 I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT)
     10 I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X)  W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1
     11 I X="@" Q:'REQD  W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1
     12 I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q
     13 I X?1"?".E D  G DIR1
     14 . N XHELP
     15 . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH"))
     16 . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP
     17 . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE)
     18 . I $L(DIR("?"))<80 W !,DIR("?"),!
     19 . E  D  W !
     20 . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W")
     21 . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0))
     22 I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1
     23 I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0  D ERR G DIR1
     24 I $G(ORDIALOG(PROMPT,"LIST")) D  Q:$L(Y)  I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1
     25 . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")"
     26 . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN)
     27 . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q
     28 . ; S ORX=$$EXPLIST(X) F  S Y(Y+1)=$$FIND
     29 I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1
     30 I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1
     31 I "^F^N^S^Y^"[(U_DATATYPE_U),'REPL D  I $G(DDER) D ERR G DIR1
     32 . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's
     33 . S DIR("V")="" D ^DIR ; silent
     34 Q
     35 ;
     36ERR ; -- show help msg on error
     37 W:$D(DIR("?")) $C(7),!,DIR("?"),!
     38 Q
     39 ;
     40FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name)
     41 N Y,XP,CNT,MATCH,I,DIR
     42 S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X)
     43 S CNT=0,XP="" F  S XP=$O(@LIST@("B",XP)) Q:XP=""  I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP
     44 I X=+X S Y=$G(@LIST@(X)) I $L(Y) W "   "_$P(Y,U,2) G:$$OK FQ S X="" W "   " ;force entire text to echo if CNT=1
     45 I 'CNT S Y="" G FQ
     46 I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ
     47 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
     48 S DIR("?")="Select the desired value, by number"
     49 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ
     50 S Y=MATCH(Y) W "  "_$P(Y,U,2)
     51FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV
     52 Q Y
     53 ;
     54OK() ; -- Return 1 or 0, if selected item is correct
     55 N X,Y,DIR I CNT'>0 Q 1 ;no other matches
     56 S DIR(0)="YA",DIR("A")="   ...OK? ",DIR("B")="YES"
     57 S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list"
     58 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
     59 Q +Y
     60 ;
     61DIC ; -- ^DIC lookup on X, return Y
     62 N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2)
     63 S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file?
     64 I X=" ",ORDITM D SPBAR W $S(Y>0:"   "_X,1:$C(7)_"  ??") Q
     65 I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q
     66 I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q  ; default
     67 S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC
     68 S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S")
     69 S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
     70 S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) ""   (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF
     71 S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^")
     72 I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M"
     73 D @ORDIC,SETDISV:Y&ORDITM
     74 I DIC(0)["S",X'=$P(Y,"^",2) W "  ",$P(Y,"^",2)
     75 Q
     76 ;
     77SPACE(FILE) ; -- Resolve spbar-return for ptrs
     78 N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":")
     79 I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X
     80 S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT))
     81 S:Y X=$P(@(ROOT_Y_",0)"),U)
     82 Q X
     83 ;
     84SPBAR ; -- Resolve spbar-return for #101.43
     85 N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^")
     86 F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q
     87 Q:'$L(SDX)  S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1)
     88 S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1
     89 Q
     90 ;
     91SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43
     92 N SDX,I Q:'$L($P(Y,U,2))
     93 S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S."
     94 F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q
     95 Q:'$L(SDX)  S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2)
     96 Q
     97 ;
     98DT ; -- %DT validation on X, return Y
     99 N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X)
     100 I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed
     101 I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed
     102 D ^%DT Q:Y'>0
     103 I $G(BEG) D  Q:Y<0
     104 . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only
     105 . I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q
     106 I $G(END) D  Q:Y<0
     107 . I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only
     108 . I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q
     109 I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text
     110 Q
     111DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT"
     112 I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q
     113 S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2)
     114 S Y=$E(D) I "VT"'[Y S Y=-1 Q
     115 I (D["+")!(D["-") D  Q:Y<0
     116 . N SIGN,OFFSET,X1,X2
     117 . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q
     118 . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q
     119 . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g.
     120 I '$L(T)&(DOMAIN["R") S Y=-1 Q  ; time missing, required
     121 I $L(T) D  I '$D(T) S Y=-1 Q
     122 . I '(DOMAIN["T"!(DOMAIN["R")) K T Q  ; time prohibited
     123 . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q
     124 . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T))
     125 S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error
     126 Q
     127 ;
     128RELDT(X) ; -- Returns 1 or 0, if X is relative date
     129 N Y S X=$G(X)
     130 I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1
     131 E  S Y=0
     132 Q Y
     133 ;
     134FMDT(X) ; -- Return FM form of date X
     135 N Y,%DT S %DT="T" D ^%DT
     136 Q Y
     137 ;
     138WP ; -- edit WP field
     139 N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT
     140 S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1
     141 S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ)
     142 I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8)
     143 I 'ORLINEDT,'REQD,'$$EDITWP Q  ;94
     144WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":")
     145 D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q
     146 I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q
     147 I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q  ;empty
     148 S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1
     149 I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE))  G WP1
     150 Q
     151 ;
     152EDITWP() ; -- Want to edit WP field?
     153 N X,Y,%,%Y
     154 W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST))
     155 I 'Y,REQD Q 1 ; no data, req'd
     156 W:'Y !,"  No existing text",! I Y D  ; show comments
     157 . N X,DIWL,DIWR,DIWF,ORI
     158 . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W")
     159 . S ORI=0 F  S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0  S X=$G(^(ORI,0)) D:$L(X) ^DIWP
     160 . D ^DIWW
     161ED1 S %=$S($D(OREDIT):1,1:2) W "  Edit" D YN^DICN
     162 I %=0 W !,"  Enter 'YES' if you wish to go into the editor.",!,"  Enter 'NO' if you do not wish to edit at this time.",! G ED1
     163 S Y=$S(%<0:"^",%=2:0,1:1)
     164 Q Y
     165 ;
     166LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd
     167 N X,Y
     168 S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1
     169 E  S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1
     170 Q Y
     171 ;
     172RETURN() ; -- press return to cont
     173 N X W !,"Press <return> to continue ..." R X:DTIME
     174 Q ""
     175 ;
     176DONE() ; -- Done editing?
     177 N DIR,X,Y
     178 S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO"
     179 S DIR("?")="Enter YES to exit this order, or NO to continue editing"
     180 D ^DIR
     181 Q +Y
     182 ;
     183HELP(TYPE) ; -- Returns default help msg for TYPE prompt
     184 N Y S Y=""
     185 I TYPE="D" S Y="Enter a date[/time]."
     186 I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW."
     187 I TYPE="F" S Y="Enter a string of text."
     188 I TYPE="N" S Y="Enter a number."
     189 I TYPE="S" S Y="Enter an item from the list."
     190 I TYPE="Y" S Y="Enter YES or NO."
     191 I TYPE="P" S Y="Enter an item from the file."
     192 I TYPE="W" S Y=""
     193 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR.m

    r613 r623  
    1 ORCDLR  ;SLC/MKB-Utility functions for LR dialogs ;11/22/06
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,71,79,175,243**;Dec 17, 1997;Build 242
    3 TEST    ; -- Setup ORTEST() array of ordering parameters
    4         N OI,TST,WRD,I,DG
    5         S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI
    6         I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
    7         S WRD="GenWardInstructions" I $O(ORTEST(WRD,0)) D  W !
    8         . W ! S I=0 F  S I=$O(ORTEST(WRD,I)) Q:I'>0  W !,ORTEST(WRD,I,0)
    9         S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB"
    10         S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG
    11         Q
    12         ;
    13 CKTYP   ; -- ck type of test [Exit Action]
    14         N X,Y S X=$G(ORDIALOG(PROMPT,INST)) Q:'X
    15         S Y=$P($G(^ORD(101.43,+X,"LR")),U,7)
    16         I (Y="O")!(Y="N") W $C(7),!,"This test may not be ordered anymore.  Please select another test." S ORQUIT=1 D WAIT Q
    17         Q
    18         ;
    19 WAIT    ; -- Wait for user
    20         N X W !,"Press <return> to continue ..." R X:DTIME
    21         Q
    22         ;
    23 SHOWMAX ; -- Setup max days allowed for cont orders
    24         K ^TMP($J,"ORCDLR SHOWMAX")
    25         D ZERO^PSS51P1(+ORSCH,,,,"ORCDLR SHOWMAX")
    26         I $S('$G(ORSCH):1,"CD"'[$P($G(^TMP($J,"ORCDLR SHOWMAX",+ORSCH,5)),U):1,1:0) K ORDIALOG(PROMPT,INST) Q  ;just in case
    27         ;I $S('$G(ORSCH):1,"CD"'[$P($G(^PS(51.1,+ORSCH,0)),U,5):1,1:0) K ORDIALOG(PROMPT,INST) Q  ;just in case
    28         N Y,OK S ORSMAX=$G(^TMP($J,"ORCDLR SHOWMAX",+ORSCH,2.5)),ORSTMS=$P($G(^(0)),U,3)
    29         ;N Y,OK S ORSMAX=$P($G(^PS(51.1,ORSCH,0)),U,7),ORSTMS=$P($G(^(0)),U,3)
    30         S ORSMAX=$S('$G(ORSMAX):ORMAX,$G(ORTYPE)="Z":ORSMAX,ORMAX<ORSMAX:ORMAX,1:ORSMAX),ORSTMS=$S(ORSMAX&ORSTMS:ORSMAX*1440\ORSTMS,1:"") ;set max days, times
    31         I FIRST,$G(ORTYPE)="Q" S Y=$G(ORDIALOG(PROMPT,INST)) I $L(Y) S OK=$$CKMAX(Y) Q:OK  K ORDIALOG(PROMPT,INST) ;Q if valid, else fall thru and prompt
    32         W !!,"Maximum number of days for continuous orders is "_ORSMAX_"; enter a duration",!,"as either a number of days (3) or Xnumber of times (X3).",!
    33         K ^TMP($J,"ORCDLR SHOWMAX")
    34         Q
    35         ;
    36 CKMAX(X)        ; -- Ck duration X against max allowed
    37         N Y S Y=1
    38         I +X=X S Y=$S(X<0:"0^Cannot order in the past.",'ORSMAX:1,X'>ORSMAX:1,1:"0^Cannot order more than "_ORSMAX_" days in advance.") G CKQ
    39         I (X'?1"X"1.N),(X'?1"x"1.N) S Y="0^Enter either a number of days or X_number of times." G CKQ
    40         I ORSTMS,+$E(X,2,9)>ORSTMS S Y="0^Cannot order more than "_ORSTMS_" time* s." G CKQ
    41         I 'ORSTMS,+$E(X,2,9)>ORSMAX S Y="0^Cannot order for more than "_ORSMAX_" days." G CKQ ; day of week schedule
    42         S Y=1
    43 CKQ     Q Y
    44         ;
    45 SAMPLE()        ; -- Get default sample from Test for INST
    46         N X,Y I $L($G(LRFSAMP)) Q LRFSAMP
    47         I (ORCOLLCT="LC")!(ORCOLLCT="I") S X=$G(ORTEST("Lab CollSamp")) G SAMPQ
    48         S X=$G(ORTEST("Unique CollSamp")) G:X SAMPQ
    49         S X=$G(ORTEST("Default CollSamp"))
    50 SAMPQ   S Y=+$G(ORTEST("CollSamp",+X))
    51         Q Y
    52         ;
    53 ENSAMP  ; -- Get list of samples to pick from
    54         Q:$G(ORDIALOG(PROMPT,"LIST"))  N I,CNT,X,Y S (I,CNT)=0
    55         F  S I=$O(ORTEST("CollSamp",I)) Q:I'>0  S X=$G(ORTEST("CollSamp",I)) D
    56         . S Y=$P(X,U,1,2)_"   "_$$GET1^DIQ(61,+$P(X,U,3)_",",.01)_"  "_$P(X,U,4)
    57         . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=Y
    58         . S ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X
    59         S:CNT ORDIALOG(PROMPT,"LIST")=CNT_$S($$SECTION'="MI":"^1",1:"")
    60         Q
    61         ;
    62 ASKSAMP()       ; -- Ask for Collection Sample?
    63         N X,Y,DIR,DEFSAMP,SAMP0
    64         S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0))
    65         I $G(ORTYPE)="Z",DEFSAMP Q 1
    66         I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) W !!,"Lab will collect "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_".",! Q 0
    67         I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask
    68         I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask
    69         I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice
    70         S DIR(0)="YA",DIR("A")="Is "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_" the correct sample to collect? ",DIR("B")="Yes"
    71         D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 0
    72         D:'Y LIST^ORCD
    73         Q 'Y
    74         ;
    75 SECTION()       ; -- Returns Lab section of Orderable Item
    76         N PTR,X
    77         S PTR=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
    78         S X=$P($G(^ORD(101.43,+$G(ORDIALOG(PTR,1)),"LR")),U,6)
    79         Q X
    80         ;
    81 SHOWCOMM(SAMP)  ; -- Show comments for sample
    82         Q:'$G(SAMP)  Q:'$G(ORTEST)  N ORCOMM,I
    83         D SCOM^LR7OR3(+ORTEST,SAMP,.ORCOMM)
    84         S I=0 F  S I=$O(ORCOMM(I)) Q:I'>0  W !,ORCOMM(I,0)
    85         Q
    86         ;
    87 SPECIMEN()      ; -- Get default specimen from Sample for INST
    88         N X,Y I $L($G(LRFSPEC)) S Y=LRFSPEC
    89         E  S X=$$VAL^ORCD("COLLECTION SAMPLE"),Y=+$P($G(^LAB(62,+X,0)),U,2)
    90         Q Y
    91         ;
    92 SPECHELP        ; -- Xecutable help for Specimen prompt
    93         I '$D(^LAB(61,"E")) D P^ORCDLGH Q
    94         W !,"Choose from: "
    95         N SP,I,DONE,CNT S (CNT,DONE)=0,SP=""
    96         F  S SP=$O(^LAB(61,"E",SP)) Q:SP=""  S I=+$O(^(SP,0)) I I D
    97         . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q
    98         . W !,"     "_$P($G(^LAB(61,I,0)),U)
    99         Q
    100         ;
    101 URGENCY ; -- Get list of urgencies to pick from
    102         Q:$D(ORDIALOG(PROMPT,"LIST"))  N I,J,X
    103         I $G(ORTEST("Default Urgency")) S ORDIALOG(PROMPT,"LIST")="1^1",ORDIALOG(PROMPT,"LIST",1)=ORTEST("Default Urgency") Q  ; Forced Urgency
    104         I '$D(ORTEST("Urgencies")) S ORDIALOG(PROMPT,"LIST")="0^1" Q
    105         S (I,J)=0 F  S I=$O(ORTEST("Urgencies",I)) Q:I'>0  D
    106         . S X=ORTEST("Urgencies",I) I $G(ORCOLLCT)="LC",'$P($G(^LAB(62.05,+X,0)),U,2) Q  ; Lab cannot collect
    107         . S J=J+1,ORDIALOG(PROMPT,"LIST",J)=X,ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X
    108         S ORDIALOG(PROMPT,"LIST")=J_"^1"
    109         Q
    110         ;
    111 ASKURG()        ; -- Ask urgency prompt?
    112         I $G(ORTEST("Default Urgency")) Q 0 ; Forced Urgency
    113         I FIRST,$G(ORL) Q $$GET^XPAR("ALL^"_ORL,"LR ASK URGENCY")
    114         Q (+$G(ORDIALOG(PROMPT,"LIST"))>1)
    115         ;
    116 REQDCOMM()      ; -- Process required comments
    117         I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 0 ;edit as WP
    118         N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM
    119         S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN")
    120         S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
    121         S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
    122         S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) Q:'REQDCOMM 1
    123         I $G(ORTYPE)="Z",$P($G(^LAB(62.07,+REQDCOMM,0)),U)'="ORDER COMMENT" Q 1
    124         X:$D(^LAB(62.07,REQDCOMM,.1)) ^(.1)
    125         S (CNT,I)=0 K REQDCOMM
    126         F  S I=$O(LRTCOM(LRTEST(1),I)) Q:I'>0  S CNT=CNT+1,REQDCOMM(CNT,0)=LRTCOM(LRTEST(1),I)
    127         S:$L($G(LRCCOM)) CNT=CNT+1,REQDCOMM(CNT,0)=LRCCOM
    128         I CNT S REQDCOMM(0)="^^"_CNT_U_CNT_U_DT_U_U,ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_")" M ^TMP("ORWORD",$J,PROMPT,INST)=REQDCOMM
    129 RQ      Q 1
    130         ;
    131 XHELP(PTR)      ; -- Xecutable help
    132         I $D(ORDIALOG(PTR,"LIST")),X="?"!$P(ORDIALOG(PTR,"LIST"),U,2) D LIST^ORCD Q
    133         D P^ORCDLGH ; ??-help
    134         Q
    135         ;
    136 CHANGED(FLD)    ; -- Kill dependent values when FLD changes
    137         N PROMPTS,P,NAME,PTR K ORCOLLCT
    138         S PROMPTS="COLLECTION SAMPLE^SPECIMEN^WORD PROCESSING 1^START DATE/TIME"
    139         S:FLD="OI" PROMPTS="COLLECTION TYPE^"_PROMPTS_"^LAB URGENCY"
    140         F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P),PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) I PTR K ORDIALOG(PTR,ORI),ORDIALOG(PTR,"LIST")
    141         Q
    142         ;
    143 LB(ORDER)       ; -- Returns 1 or 0, if "LB #" is already in text
    144         N I,Y S I=0,Y=0
    145         F  S I=$O(^OR(100,+ORDER,1,I)) Q:I'>0  I $G(^(I,0))["LB #" S Y=1 Q
    146         Q Y
    147         ;
    148 DATE(X) ; Free text input to FM time
    149         N %DT,Y
    150         D ^%DT
    151         Q Y
    152         ;
    153 XSCH    ; -- xecutable help for schedule prompt
    154         N X,IFN,CNT,Z,DONE
    155         K ^TMP($J,"ORSCLR XSCH")
    156         D AP^PSS51P1("LR",,,,"ORSCLR XSCH")
    157         W !!,"Choose from:" S CNT=1
    158         S X="" F  S X=$O(^TMP($J,"ORSCLR XSCH","APLR",X)) Q:X=""  S IFN=0 D  Q:$G(DONE)
    159         .;S X="" F  S X=$O(^PS(51.1,"APLR",X)) Q:X=""  S IFN=0 D  Q:$G(DONE)
    160         . F  S IFN=$O(^TMP($J,"ORSCLR XSCH","APLR",X,IFN)) Q:IFN'>0  D  Q:$G(DONE)
    161         . .;F  S IFN=$O(^PS(51.1,"APLR",X,IFN)) Q:IFN'>0  D  Q:$G(DONE)
    162         .. W !,"   "_X S CNT=CNT+1 Q:CNT'>(IOSL-5)  S CNT=0
    163         .. W !,"   '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1
    164         W !
    165         K ^TMP($J,"ORSCLR XSCH")
    166         Q
    167         ;
    168 MULT(ORIFN,CTYPE,CDATE) ;check multiple orders from VALID^ORCDLR1
    169         N KID,OREVENT,ORSTRT,OK,X,Y,%DT
    170         I '$D(CTYPE) S CTYPE=$$VALUE^ORCSAVE2(ORIFN,"COLLECT")
    171         Q:"SPWC"[CTYPE 0  ; only check LC and I
    172         I '$D(CDATE) S CDATE=$$VALUE^ORCSAVE2(ORIFN,"START")
    173         D AM^ORCSAVE2:CDATE="AM",NEXT^ORCSAVE2:CDATE="NEXT" ; returns X
    174         S %DT="T" S:'$D(X) X=CDATE  D ^%DT I Y<1 Q 0
    175         D SCHEDULE^ORCSEND1(ORIFN,"LR",.ORSTRT,Y) Q:ORSTRT'>1 0 ; get all starts
    176         S KID=0,OK=1 F  S KID=$O(ORSTRT(KID)) Q:'KID!('OK)  D
    177         . I CTYPE="LC" S OK=$$LABCOLL^ORCDLR1(KID) Q
    178         . S OK=$$IMMCOLL^ORCDLR1(KID)
    179         I OK Q 0
    180         Q "1^One or more of the multiple orders will be changed to Ward Collect"
     1ORCDLR ;SLC/MKB-Utility functions for LR dialogs ;6/11/97  11:47
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,71,79,175**;Dec 17, 1997
     3TEST ; -- Setup ORTEST() array of ordering parameters
     4 N OI,TST,WRD,I,DG
     5 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI
     6 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
     7 S WRD="GenWardInstructions" I $O(ORTEST(WRD,0)) D  W !
     8 . W ! S I=0 F  S I=$O(ORTEST(WRD,I)) Q:I'>0  W !,ORTEST(WRD,I,0)
     9 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB"
     10 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG
     11 Q
     12 ;
     13CKTYP ; -- ck type of test [Exit Action]
     14 N X,Y S X=$G(ORDIALOG(PROMPT,INST)) Q:'X
     15 S Y=$P($G(^ORD(101.43,+X,"LR")),U,7)
     16 I (Y="O")!(Y="N") W $C(7),!,"This test may not be ordered anymore.  Please select another test." S ORQUIT=1 D WAIT Q
     17 Q
     18 ;
     19WAIT ; -- Wait for user
     20 N X W !,"Press <return> to continue ..." R X:DTIME
     21 Q
     22 ;
     23SHOWMAX ; -- Setup max days allowed for cont orders
     24 I $S('$G(ORSCH):1,"CD"'[$P($G(^PS(51.1,+ORSCH,0)),U,5):1,1:0) K ORDIALOG(PROMPT,INST) Q  ;just in case
     25 N Y,OK S ORSMAX=$P($G(^PS(51.1,ORSCH,0)),U,7),ORSTMS=$P($G(^(0)),U,3)
     26 S ORSMAX=$S('$G(ORSMAX):ORMAX,$G(ORTYPE)="Z":ORSMAX,ORMAX<ORSMAX:ORMAX,1:ORSMAX),ORSTMS=$S(ORSMAX&ORSTMS:ORSMAX*1440\ORSTMS,1:"") ;set max days, times
     27 I FIRST,$G(ORTYPE)="Q" S Y=$G(ORDIALOG(PROMPT,INST)) I $L(Y) S OK=$$CKMAX(Y) Q:OK  K ORDIALOG(PROMPT,INST) ;Q if valid, else fall thru and prompt
     28 W !!,"Maximum number of days for continuous orders is "_ORSMAX_"; enter a duration",!,"as either a number of days (3) or Xnumber of times (X3).",!
     29 Q
     30 ;
     31CKMAX(X) ; -- Ck duration X against max allowed
     32 N Y S Y=1
     33 I +X=X S Y=$S(X<0:"0^Cannot order in the past.",'ORSMAX:1,X'>ORSMAX:1,1:"0^Cannot order more than "_ORSMAX_" days in advance.") G CKQ
     34 I (X'?1"X"1.N),(X'?1"x"1.N) S Y="0^Enter either a number of days or X_number of times." G CKQ
     35 I ORSTMS,+$E(X,2,9)>ORSTMS S Y="0^Cannot order more than "_ORSTMS_" time* s." G CKQ
     36 I 'ORSTMS,+$E(X,2,9)>ORSMAX S Y="0^Cannot order for more than "_ORSMAX_" days." G CKQ ; day of week schedule
     37 S Y=1
     38CKQ Q Y
     39 ;
     40SAMPLE() ; -- Get default sample from Test for INST
     41 N X,Y I $L($G(LRFSAMP)) Q LRFSAMP
     42 I (ORCOLLCT="LC")!(ORCOLLCT="I") S X=$G(ORTEST("Lab CollSamp")) G SAMPQ
     43 S X=$G(ORTEST("Unique CollSamp")) G:X SAMPQ
     44 S X=$G(ORTEST("Default CollSamp"))
     45SAMPQ S Y=+$G(ORTEST("CollSamp",+X))
     46 Q Y
     47 ;
     48ENSAMP ; -- Get list of samples to pick from
     49 Q:$G(ORDIALOG(PROMPT,"LIST"))  N I,CNT,X,Y S (I,CNT)=0
     50 F  S I=$O(ORTEST("CollSamp",I)) Q:I'>0  S X=$G(ORTEST("CollSamp",I)) D
     51 . S Y=$P(X,U,1,2)_"   "_$$GET1^DIQ(61,+$P(X,U,3)_",",.01)_"  "_$P(X,U,4)
     52 . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=Y
     53 . S ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X
     54 S:CNT ORDIALOG(PROMPT,"LIST")=CNT_$S($$SECTION'="MI":"^1",1:"")
     55 Q
     56 ;
     57ASKSAMP() ; -- Ask for Collection Sample?
     58 N X,Y,DIR,DEFSAMP,SAMP0
     59 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0))
     60 I $G(ORTYPE)="Z",DEFSAMP Q 1
     61 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) W !!,"Lab will collect "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_".",! Q 0
     62 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask
     63 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask
     64 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice
     65 S DIR(0)="YA",DIR("A")="Is "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_" the correct sample to collect? ",DIR("B")="Yes"
     66 D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 0
     67 D:'Y LIST^ORCD
     68 Q 'Y
     69 ;
     70SECTION() ; -- Returns Lab section of Orderable Item
     71 N PTR,X
     72 S PTR=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
     73 S X=$P($G(^ORD(101.43,+$G(ORDIALOG(PTR,1)),"LR")),U,6)
     74 Q X
     75 ;
     76SHOWCOMM(SAMP) ; -- Show comments for sample
     77 Q:'$G(SAMP)  Q:'$G(ORTEST)  N ORCOMM,I
     78 D SCOM^LR7OR3(+ORTEST,SAMP,.ORCOMM)
     79 S I=0 F  S I=$O(ORCOMM(I)) Q:I'>0  W !,ORCOMM(I,0)
     80 Q
     81 ;
     82SPECIMEN() ; -- Get default specimen from Sample for INST
     83 N X,Y I $L($G(LRFSPEC)) S Y=LRFSPEC
     84 E  S X=$$VAL^ORCD("COLLECTION SAMPLE"),Y=+$P($G(^LAB(62,+X,0)),U,2)
     85 Q Y
     86 ;
     87SPECHELP ; -- Xecutable help for Specimen prompt
     88 I '$D(^LAB(61,"E")) D P^ORCDLGH Q
     89 W !,"Choose from: "
     90 N SP,I,DONE,CNT S (CNT,DONE)=0,SP=""
     91 F  S SP=$O(^LAB(61,"E",SP)) Q:SP=""  S I=+$O(^(SP,0)) I I D
     92 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q
     93 . W !,"     "_$P($G(^LAB(61,I,0)),U)
     94 Q
     95 ;
     96URGENCY ; -- Get list of urgencies to pick from
     97 Q:$D(ORDIALOG(PROMPT,"LIST"))  N I,J,X
     98 I $G(ORTEST("Default Urgency")) S ORDIALOG(PROMPT,"LIST")="1^1",ORDIALOG(PROMPT,"LIST",1)=ORTEST("Default Urgency") Q  ; Forced Urgency
     99 I '$D(ORTEST("Urgencies")) S ORDIALOG(PROMPT,"LIST")="0^1" Q
     100 S (I,J)=0 F  S I=$O(ORTEST("Urgencies",I)) Q:I'>0  D
     101 . S X=ORTEST("Urgencies",I) I $G(ORCOLLCT)="LC",'$P($G(^LAB(62.05,+X,0)),U,2) Q  ; Lab cannot collect
     102 . S J=J+1,ORDIALOG(PROMPT,"LIST",J)=X,ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X
     103 S ORDIALOG(PROMPT,"LIST")=J_"^1"
     104 Q
     105 ;
     106ASKURG() ; -- Ask urgency prompt?
     107 I $G(ORTEST("Default Urgency")) Q 0 ; Forced Urgency
     108 I FIRST,$G(ORL) Q $$GET^XPAR("ALL^"_ORL,"LR ASK URGENCY")
     109 Q (+$G(ORDIALOG(PROMPT,"LIST"))>1)
     110 ;
     111REQDCOMM() ; -- Process required comments
     112 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 0 ;edit as WP
     113 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM
     114 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN")
     115 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
     116 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
     117 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) Q:'REQDCOMM 1
     118 I $G(ORTYPE)="Z",$P($G(^LAB(62.07,+REQDCOMM,0)),U)'="ORDER COMMENT" Q 1
     119 X:$D(^LAB(62.07,REQDCOMM,.1)) ^(.1)
     120 S (CNT,I)=0 K REQDCOMM
     121 F  S I=$O(LRTCOM(LRTEST(1),I)) Q:I'>0  S CNT=CNT+1,REQDCOMM(CNT,0)=LRTCOM(LRTEST(1),I)
     122 S:$L($G(LRCCOM)) CNT=CNT+1,REQDCOMM(CNT,0)=LRCCOM
     123 I CNT S REQDCOMM(0)="^^"_CNT_U_CNT_U_DT_U_U,ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_")" M ^TMP("ORWORD",$J,PROMPT,INST)=REQDCOMM
     124RQ Q 1
     125 ;
     126XHELP(PTR) ; -- Xecutable help
     127 I $D(ORDIALOG(PTR,"LIST")),X="?"!$P(ORDIALOG(PTR,"LIST"),U,2) D LIST^ORCD Q
     128 D P^ORCDLGH ; ??-help
     129 Q
     130 ;
     131CHANGED(FLD) ; -- Kill dependent values when FLD changes
     132 N PROMPTS,P,NAME,PTR K ORCOLLCT
     133 S PROMPTS="COLLECTION SAMPLE^SPECIMEN^WORD PROCESSING 1^START DATE/TIME"
     134 S:FLD="OI" PROMPTS="COLLECTION TYPE^"_PROMPTS_"^LAB URGENCY"
     135 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P),PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) I PTR K ORDIALOG(PTR,ORI),ORDIALOG(PTR,"LIST")
     136 Q
     137 ;
     138LB(ORDER) ; -- Returns 1 or 0, if "LB #" is already in text
     139 N I,Y S I=0,Y=0
     140 F  S I=$O(^OR(100,+ORDER,1,I)) Q:I'>0  I $G(^(I,0))["LB #" S Y=1 Q
     141 Q Y
     142 ;
     143DATE(X) ; Free text input to FM time
     144 N %DT,Y
     145 D ^%DT
     146 Q Y
     147 ;
     148XSCH ; -- xecutable help for schedule prompt
     149 N X,IFN,CNT,Z,DONE
     150 W !!,"Choose from:" S CNT=1
     151 S X="" F  S X=$O(^PS(51.1,"APLR",X)) Q:X=""  S IFN=0 D  Q:$G(DONE)
     152 . F  S IFN=$O(^PS(51.1,"APLR",X,IFN)) Q:IFN'>0  D  Q:$G(DONE)
     153 .. W !,"   "_X S CNT=CNT+1 Q:CNT'>(IOSL-5)  S CNT=0
     154 .. W !,"   '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1
     155 W !
     156 Q
     157 ;
     158MULT(ORIFN,CTYPE,CDATE) ;check multiple orders from VALID^ORCDLR1
     159 N KID,OREVENT,ORSTRT,OK,X,Y,%DT
     160 I '$D(CTYPE) S CTYPE=$$VALUE^ORCSAVE2(ORIFN,"COLLECT")
     161 Q:"SPWC"[CTYPE 0  ; only check LC and I
     162 I '$D(CDATE) S CDATE=$$VALUE^ORCSAVE2(ORIFN,"START")
     163 D AM^ORCSAVE2:CDATE="AM",NEXT^ORCSAVE2:CDATE="NEXT" ; returns X
     164 S %DT="T" S:'$D(X) X=CDATE  D ^%DT I Y<1 Q 0
     165 D SCHEDULE^ORCSEND1(ORIFN,"LR",.ORSTRT,Y) Q:ORSTRT'>1 0 ; get all starts
     166 S KID=0,OK=1 F  S KID=$O(ORSTRT(KID)) Q:'KID!('OK)  D
     167 . I CTYPE="LC" S OK=$$LABCOLL^ORCDLR1(KID) Q
     168 . S OK=$$IMMCOLL^ORCDLR1(KID)
     169 I OK Q 0
     170 Q "1^One or more of the multiple orders will be changed to Ward Collect"

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR1.m

    r613 r623  
    1 ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02  14:45
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141,143,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN      ; -- Entry Action for LR OTHER LAB TESTS order dialog
    5         D GETIMES S ORMAX=0
    6         S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
    7         Q
    8         ;
    9 EX      ; -- Exit Action for order dialog
    10         K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT
    11         I $G(ORXL) S ORL=ORXL K ORXL
    12         Q
    13         ;
    14 GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime
    15         N I,X,CNT,ON K ORTIME
    16         I '$D(VALIDT) D
    17         . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2)
    18         . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound
    19         S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2))
    20         I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT)
    21         D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N")
    22         S (I,CNT)=0 F  S I=$O(ORTIME(I)) Q:I'>0  S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off
    23         S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection
    24         S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll
    25         S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME)
    26         I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON
    27         Q
    28         ;
    29 DEFTIME()       ; -- Returns default collection time
    30         I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE
    31         I '$D(ORCOLLCT) Q ""
    32         N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D  Q:$L(Y) Y
    33         . S Y=$$RECALL^ORCD(PROMPT)
    34         . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q
    35         . S EDITONLY=1
    36         ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"")
    37         D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST"))
    38         D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0))
    39         Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY")
    40         ;
    41 IMMDEF()        ; -- Returns immediate collect default
    42         N X,Y S X=$$DEFTIME^LR7OV4(ORDIV)
    43         S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U))
    44         Q Y
    45         ;
    46 COLLTIME        ; -- Get list of common collection times
    47         I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME)
    48         I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q
    49         Q:$G(ORDIALOG(PROMPT,"LIST"))  Q:'$O(ORTIME(0))
    50         N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2)
    51         S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY=""
    52         S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0))
    53         S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT"
    54         S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM"
    55         G:ORTIME'>1 CTMQ ; only NEXT
    56         S I=NEXT F  S I=$O(ORTIME(I)) Q:I'>0  S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
    57         I NEXT>$O(ORTIME(0)) D  ;add morning times before NEXT to T+1
    58         . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0))
    59         . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")"
    60         . F  S I=$O(ORTIME(I)) Q:(I'>0)!(I'<NEXT)  S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
    61 CTMQ    S ORDIALOG(PROMPT,"LIST")=CNT
    62         Q
    63         ;
    64 NEXTCOLL(START) ; -- Returns the next day that routine lab collects are done
    65         N X,Y,%DT,OFFSET,ORDAYS,PARAM I '$O(ORTIME(0)) Q "" ; no Lab collect
    66         S:'$D(START) START="T" S OFFSET=+$P(START,"+",2),START=$P(START,"+")
    67         F ORDAYS=1:1:7 D  Q:$D(X)  S OFFSET=OFFSET+1 ; ck up to a week
    68         . S %DT="X",X=START_$S(OFFSET:"+"_OFFSET,1:"")
    69         . D ^%DT I Y'>0 K X Q
    70         . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q
    71         . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y))
    72         . I '$$GET^XPAR("ALL",PARAM) K X Q
    73         . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q
    74         S Y=$S($D(X):X,1:"")
    75         Q Y
    76         ;
    77 TIME(X) ; -- Returns 00:00AM from 0000 FileMan time
    78         N HOUR,MIN,XM,Y
    79         S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM"
    80         I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12
    81         S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0
    82         S Y=HOUR_":"_MIN_XM
    83         Q Y
    84         ;
    85 LISTCOLL        ; -- Lists the routine collection times for ??-help
    86         I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q
    87         N I,X S I=0,X=""
    88         F  S I=$O(ORTIME(I)) Q:I'>0  S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I))
    89         W !,"Routine collection times are "_X_"."
    90         W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time."
    91         Q
    92         ;
    93 IMMTIMES        ; -- Show the valid date/times for immediate collect
    94         N I S I=0
    95         F  S I=$O(ORIMTIME(I)) Q:I'>0  W !,ORIMTIME(I)
    96         Q
    97         ;
    98 CKDATE(X)       ; -- Valid coll time for SP or WC?
    99         S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1
    100         I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1
    101         N Y,%DT,D
    102         I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time"
    103         S D=$P(X,".") I D<DT Q "0^Cannot order for past days"
    104         I $P(X,".",2),X<$$NOW^XLFDT,'$G(OREVENT),$G(ORTYPE)'="Z" Q "0^The requested collection time has passed"
    105         I D>$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance"
    106         Q 1
    107         ;
    108 IMMCOLL(X)      ; -- Valid immediate collection date/time?
    109         I X?1"NOW+"1.N1"'" Q 1
    110         I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time"
    111         Q $$VALID^LR7OV4(ORDIV,X)
    112         ;
    113 LABCOLL(ORXTIM) ; -- Valid lab collection date/time?
    114         ;    Returns valid flag of 1 or 0^message
    115         N I,X,Y,%DT,ORD,ORT,PARAM,ORDY
    116         I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!"
    117         I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1
    118         I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time"
    119         ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??)
    120         S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2)
    121         S:ORT="." ORT=+("."_$G(ORTIME("AM")))
    122         I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time"
    123 LC1     ; -- check date
    124         I ORD<DT Q "0^Can not order for past days."
    125         I ORXTIM<$$NOW^XLFDT,'$G(OREVENT) Q "0^Cannot order in the past"
    126         I $G(ORTYPE)'="Z",'$G(OREVENT),ORD=DT,$P($H,",",2)>ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed"
    127         S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I")
    128         I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance"
    129         I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1
    130         S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD))
    131         I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day"
    132         I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays"
    133         Q 1
    134         ;
    135 LABSAMP()       ; -- Lab Collect sample?
    136         N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7)
    137         Q Y
    138         ;
    139 COLLTYPE()      ; -- Returns default collection type
    140         N Y I $G(ORTYPE)="Z" S Y="" G CTQ
    141         I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ
    142         I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D  G CTQ
    143         . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1
    144         S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK")
    145         I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC")
    146 CTQ     I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC"
    147         I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC"
    148         ;S:$G(ORTYPE)="Q" EDITONLY=1
    149         I '(FIRST&EDITONLY) D HELPTYPE
    150         Q Y
    151         ;
    152 CKTYPE  ; -- Valid type for time, sample?
    153         I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q
    154         I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q
    155         I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q
    156         I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST")
    157         Q
    158         ;
    159 HELPTYPE        ; -- Xecutable help for Coll Type
    160         W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn."
    161         W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward."
    162         W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward.  This method is limited to laboratory defined collection times."
    163         W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward.  This method is available during times",!,"defined by Laboratory." W !
    164         N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD
    165         Q
    166 VALID(ORDER)    ;check collection time on release
    167         N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT
    168         S VALIDT="" D GETIMES
    169         S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START")
    170         S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT")
    171         I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17)
    172         I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK
    173         S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT))
    174         I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks
    175         W !!,$C(7),$P(OK,U,2)
    176         D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT
    177         W !,"must be edited before signing/release." K VALIDT D
    178         . N ORDIV,ORIMTIME,ORTIME,ORNP
    179         . S ORNP=$P(^OR(100,ORDER,0),U,4)
    180         . S ORACT="XX" D XX^ORCACT4 ;edit order
    181         I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK
    182         Q 0
    183         ;
    184 MULT    ; -- ck child orders
    185         N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD
    186         W !!,$P(CHGD,U,2) H 2
    187         Q
     1ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02  14:45
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141**;Dec 17, 1997
     3 ;
     4EN ; -- Entry Action for LR OTHER LAB TESTS order dialog
     5 D GETIMES S ORMAX=0
     6 S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
     7 Q
     8 ;
     9EX ; -- Exit Action for order dialog
     10 K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT
     11 I $G(ORXL) S ORL=ORXL K ORXL
     12 Q
     13 ;
     14GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime
     15 N I,X,CNT,ON K ORTIME
     16 I '$D(VALIDT) D
     17 . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2)
     18 . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound
     19 S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2))
     20 I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT)
     21 D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N")
     22 S (I,CNT)=0 F  S I=$O(ORTIME(I)) Q:I'>0  S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off
     23 S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection
     24 S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll
     25 S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME)
     26 I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON
     27 Q
     28 ;
     29DEFTIME() ; -- Returns default collection time
     30 I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE
     31 N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D  Q:$L(Y) Y
     32 . S Y=$$RECALL^ORCD(PROMPT)
     33 . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q
     34 . S EDITONLY=1
     35 ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"")
     36 D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST"))
     37 D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0))
     38 Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY")
     39 ;
     40IMMDEF() ; -- Returns immediate collect default
     41 N X,Y S X=$$DEFTIME^LR7OV4(ORDIV)
     42 S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U))
     43 Q Y
     44 ;
     45COLLTIME ; -- Get list of common collection times
     46 I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME)
     47 I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q
     48 Q:$G(ORDIALOG(PROMPT,"LIST"))  Q:'$O(ORTIME(0))
     49 N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2)
     50 S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY=""
     51 S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0))
     52 S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT"
     53 S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM"
     54 G:ORTIME'>1 CTMQ ; only NEXT
     55 S I=NEXT F  S I=$O(ORTIME(I)) Q:I'>0  S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
     56 I NEXT>$O(ORTIME(0)) D  ;add morning times before NEXT to T+1
     57 . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0))
     58 . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")"
     59 . F  S I=$O(ORTIME(I)) Q:(I'>0)!(I'<NEXT)  S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
     60CTMQ S ORDIALOG(PROMPT,"LIST")=CNT
     61 Q
     62 ;
     63NEXTCOLL(START) ; -- Returns the next day that routine lab collects are done
     64 N X,Y,%DT,OFFSET,ORDAYS,PARAM I '$O(ORTIME(0)) Q "" ; no Lab collect
     65 S:'$D(START) START="T" S OFFSET=+$P(START,"+",2),START=$P(START,"+")
     66 F ORDAYS=1:1:7 D  Q:$D(X)  S OFFSET=OFFSET+1 ; ck up to a week
     67 . S %DT="X",X=START_$S(OFFSET:"+"_OFFSET,1:"")
     68 . D ^%DT I Y'>0 K X Q
     69 . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q
     70 . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y))
     71 . I '$$GET^XPAR("ALL",PARAM) K X Q
     72 . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q
     73 S Y=$S($D(X):X,1:"")
     74 Q Y
     75 ;
     76TIME(X) ; -- Returns 00:00AM from 0000 FileMan time
     77 N HOUR,MIN,XM,Y
     78 S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM"
     79 I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12
     80 S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0
     81 S Y=HOUR_":"_MIN_XM
     82 Q Y
     83 ;
     84LISTCOLL ; -- Lists the routine collection times for ??-help
     85 I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q
     86 N I,X S I=0,X=""
     87 F  S I=$O(ORTIME(I)) Q:I'>0  S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I))
     88 W !,"Routine collection times are "_X_"."
     89 W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time."
     90 Q
     91 ;
     92IMMTIMES ; -- Show the valid date/times for immediate collect
     93 N I S I=0
     94 F  S I=$O(ORIMTIME(I)) Q:I'>0  W !,ORIMTIME(I)
     95 Q
     96 ;
     97CKDATE(X) ; -- Valid coll time for SP or WC?
     98 S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1
     99 I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1
     100 N Y,%DT,D
     101 I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time"
     102 S D=$P(X,".") I D<DT Q "0^Cannot order for past days"
     103 I $P(X,".",2),X<$$NOW^XLFDT,'$G(OREVENT),$G(ORTYPE)'="Z" Q "0^The requested collection time has passed"
     104 I D>$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance"
     105 Q 1
     106 ;
     107IMMCOLL(X) ; -- Valid immediate collection date/time?
     108 I X?1"NOW+"1.N1"'" Q 1
     109 I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time"
     110 Q $$VALID^LR7OV4(ORDIV,X)
     111 ;
     112LABCOLL(ORXTIM) ; -- Valid lab collection date/time?
     113 ;    Returns valid flag of 1 or 0^message
     114 N I,X,Y,%DT,ORD,ORT,PARAM,ORDY
     115 I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!"
     116 I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1
     117 I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time"
     118 ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??)
     119 S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2)
     120 S:ORT="." ORT=+("."_$G(ORTIME("AM")))
     121 I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time"
     122LC1 ; -- check date
     123 I ORD<DT Q "0^Can not order for past days."
     124 I ORXTIM<$$NOW^XLFDT,'$G(OREVENT) Q "0^Cannot order in the past"
     125 I $G(ORTYPE)'="Z",'$G(OREVENT),ORD=DT,$P($H,",",2)>ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed"
     126 S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I")
     127 I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance"
     128 I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1
     129 S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD))
     130 I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day"
     131 I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays"
     132 Q 1
     133 ;
     134LABSAMP() ; -- Lab Collect sample?
     135 N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7)
     136 Q Y
     137 ;
     138COLLTYPE() ; -- Returns default collection type
     139 N Y I $G(ORTYPE)="Z" S Y="" G CTQ
     140 I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ
     141 I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D  G CTQ
     142 . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1
     143 S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK")
     144 I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC")
     145CTQ I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC"
     146 I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC"
     147 ;S:$G(ORTYPE)="Q" EDITONLY=1
     148 I '(FIRST&EDITONLY) D HELPTYPE
     149 Q Y
     150 ;
     151CKTYPE ; -- Valid type for time, sample?
     152 I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q
     153 I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q
     154 I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q
     155 I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST")
     156 Q
     157 ;
     158HELPTYPE ; -- Xecutable help for Coll Type
     159 W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn."
     160 W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward."
     161 W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward.  This method is limited to laboratory defined collection times."
     162 W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward.  This method is available during times",!,"defined by Laboratory." W !
     163 N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD
     164 Q
     165VALID(ORDER) ;check collection time on release
     166 N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT
     167 S VALIDT="" D GETIMES
     168 S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START")
     169 S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT")
     170 I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17)
     171 I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK
     172 S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT))
     173 I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks
     174 W !!,$C(7),$P(OK,U,2)
     175 D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT
     176 W !,"must be edited before signing/release." K VALIDT D
     177 . N ORDIV,ORIMTIME,ORTIME,ORNP
     178 . S ORNP=$P(^OR(100,ORDER,0),U,4)
     179 . S ORACT="XX" D XX^ORCACT4 ;edit order
     180 I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK
     181 Q 0
     182 ;
     183MULT ; -- ck child orders
     184 N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD
     185 W !!,$P(CHGD,U,2) H 2
     186 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS1.m

    r613 r623  
    1 ORCDPS1 ;SLC/MKB-Pharmacy dialog utilities ; 08 May 2002  2:12 PM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,117,141,149,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 2418   START^PSSJORDF   ^TMP("PSJMR",$J)
    5         ; DBIA 3166   EN^PSSDIN        ^TMP("PSSDIN",$J)
    6         ;
    7 EN(TYPE)        ; -- entry action for Meds dialogs
    8         S ORINPT=$$INPT^ORCD,ORCAT=$G(TYPE)
    9         I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location?
    10         I ORCAT="" D
    11         . I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT),$L($P($G(OR0),U,12)) S ORCAT=$P(OR0,U,12) Q  ;use value from order, via ORCACT4
    12         . S ORCAT=$S(ORINPT:"I",1:"O")
    13         S ORDG=+$O(^ORD(100.98,"B",$S(ORCAT="I":"UD RX",1:"O RX"),0))
    14         K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    15         I $G(ORENEW)!$G(OREWRITE)!$G(OREDIT)!$G(ORXFER) D  Q:$G(ORQUIT)
    16         . I 'ORINPT,ORCAT="I" D  Q:$G(ORQUIT)
    17         .. N OI S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1
    18         .. I '$O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORQUIT=1 W $C(7),!!,"This order may not be placed at this location!" Q
    19         . K ORDIALOG($$PTR("START DATE/TIME"),1)
    20         . K ORDIALOG($$PTR("NOW"),1) Q:ORCAT'="O"
    21         . N WP S WP=$$PTR("WORD PROCESSING 1")
    22         . I '$G(ORXFER),'$$DRAFT^ORWDX2($G(ORIFN)) K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP)
    23         . I $G(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J)
    24         I ORINPT,ORCAT="O" W $C(7),!!,"NOTE: This will create an outpatient prescription for an inpatient!",!
    25         Q
    26         ;
    27 EN1     ; -- setup Meds dialog for quick order editor using ORDG
    28         N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
    29         I $P(DG," ")="O"!(DG="SPLY") S ORINPT=0,ORCAT="O"
    30         E  S ORINPT=1,ORCAT="I"
    31         K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    32         Q
    33         ;
    34 ENOI    ; -- setup OI prompt
    35         N D S D=$G(ORDIALOG(PROMPT,"D"))
    36         S:D="S.RX" ORDIALOG(PROMPT,"D")=$S(ORCAT="I":"S.UD RX",1:"S.O RX")
    37         I ORCAT="I",'ORINPT,D="S.UD RX" D  ;limit to IV meds for outpt's
    38         . S ORDIALOG(PROMPT,"D")="S.IVM RX" ;ORDG=+$O(^ORD(100.98,"B","O RX",0))
    39         . S ORDIALOG(PROMPT,"?")="Enter the IV medication you wish to order for this patient."
    40         Q
    41         ;
    42 DEA     ; -- ck DEA# of ordering provider if SchedII drug
    43         Q:$G(ORTYPE)="Z"  N DEAFLG,PSOI
    44         S PSOI=+$P($G(^ORD(101.43,+$G(Y),0)),U,2) Q:PSOI'>0
    45         S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,ORCAT) Q:DEAFLG'>0  ;ok
    46         I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" K DONE Q
    47         I DEAFLG=1 W $C(7),!,"This order will require a wet signature!"
    48         Q
    49         ;
    50 CHANGED(X)      ; -- Kill dependent values when prompt X changes
    51         N PROMPTS,NAME,PTR,P,I
    52         S PROMPTS=X I X="OI" D
    53         . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DURATION^AND/THEN^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS^DAYS SUPPLY^QUANTITY^REFILLS^SERVICE CONNECTED"
    54         . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY
    55         . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    56         I X="DS" S PROMPTS="QUANTITY^REFILLS" K OREFILLS
    57         F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
    58         . S PTR=$$PTR(NAME) Q:'PTR
    59         . S I=0 F  S I=$O(ORDIALOG(PTR,I)) Q:I'>0  K ORDIALOG(PTR,I)
    60         . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR)
    61         Q
    62         ;
    63 ORDITM(OI)      ; -- Check OI, get dependent info
    64         Q:OI'>0  ;quit - no value
    65         N ORPS,ORPSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),ORPSOI=+$P($G(^(0)),U,2)
    66         S ORIV=$S($P(ORPS,U)=2:1,1:0)
    67         I $G(ORCAT)="O",'$P(ORPS,U,2) W $C(7),!,"This drug may not be used in an outpatient order." S ORQUIT=1 D WAIT Q
    68         I $G(ORCAT)="I" D  Q:$G(ORQUIT)
    69         . I $G(ORINPT),'$P(ORPS,U) W $C(7),!,"This drug may not be used in an inpatient order." S ORQUIT=1 D WAIT Q
    70         . I '$G(ORINPT),'ORIV W $C(7),!,"This drug may not be ordered for an outpatient." S ORQUIT=1 D WAIT Q
    71         I $G(ORTYPE)="Q" D  I $G(ORQUIT) D WAIT Q
    72         . N DEAFLG S DEAFLG=$$OIDEA^PSSUTLA1(ORPSOI,ORCAT) Q:DEAFLG'>0  ;ok
    73         . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q
    74         . I DEAFLG=1 W $C(7),!,"This order will require a wet signature!"
    75 OI1     ; -ck NF status
    76         I $P(ORPS,U,6),'$G(ORENEW) D  ;alternative
    77         . W !!,"*** This medication is not in the formulary! ***"
    78         . N PSX,CNT,ORX,DIR,X,Y,DTOUT,DUOUT
    79         . D EN1^PSSUTIL1(.ORPSOI,ORCAT) I '$O(ORPSOI(0)) D  Q
    80         .. W !,"    There are no formulary alternatives entered for this item."
    81         .. W !,"    Please consult with your pharmacy before ordering it."
    82         . S PSX=0,CNT=0 F  S PSX=$O(ORPSOI(PSX)) Q:PSX'>0  D
    83         .. S ORX=+$O(^ORD(101.43,"ID",PSX_";99PSP",0)) Q:ORX'>0
    84         .. S CNT=CNT+1,ORPSOI("OI",CNT)=ORX_U_PSX
    85         .. S DIR("A",CNT)=$J(CNT,3)_" "_$P($G(^ORD(101.43,ORX,0)),U)
    86         . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select alternative (or <return> to continue): "
    87         . S DIR("?")="The medication selected is not in the formulary; you may select one of the above listed alternatives instead, or press <return> to continue processing this order."
    88         . Q:CNT'>0  W !,"    Formulary alternatives:" D ^DIR
    89         . I Y'>0 S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 Q
    90         . D:OI'=+ORPSOI("OI",+Y) CHANGED("OI") ;reset parameters if different
    91         . S OI=+ORPSOI("OI",+Y),ORDIALOG(PROMPT,INST)=OI,OROI=OI
    92         . S ORPSOI=+$P(ORPSOI("OI",+Y),U,2)
    93 OI2     ; -get routes, doses [also called from NF^ORCDPS]
    94         D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(ORPSOI,$G(ORCAT))  ;DBIA 2418
    95         I '$D(ORDOSE) D
    96         . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,$S($G(ORCAT)="I":"U",1:"O"),+ORVP)
    97         . K:$G(ORDOSE(1))=-1 ORDOSE
    98         Q
    99         ;
    100 NFI(OI) ; -- Show NFI restrictions, if exist
    101         N PSOI,I,J,LCNT,MAX,X,STOP
    102         S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2)
    103         D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI))  ;DBIA 3166
    104         S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W !
    105         F  S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0  D
    106         . S J=0 F  S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0  S X=$G(^(J)) D  Q:$G(STOP)
    107         .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP)  S LCNT=1
    108         .. W !,X
    109         W ! K ^TMP("PSSDIN",$J,"OI",PSOI)
    110         Q
    111         ;
    112 CONT()  ; -- Cont or stop?
    113         N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA"
    114         S DIR("A")="Press <return> to continue or ^ to stop ..."
    115         D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
    116         Q +Y
    117         ;
    118 WAIT    ; -- Wait for user
    119         N X W !,"Press <return> to continue ..." R X:DTIME
    120         Q
    121         ;
    122 ROUTES  ; -- Get med routes
    123         Q:$G(ORDIALOG(PROMPT,"LIST"))  N I,X,CNT S (I,CNT)=0
    124         F  S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0  S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3)
    125         S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT
    126         S:$G(ORTYPE)'="Z" REQD=$S(ORCAT="I":1,$P($G(^ORD(101.43,+$G(OROI),"PS")),U,5):0,1:1)
    127         Q
    128         ;
    129 DEFRTE  ; -- Get default route
    130         N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST
    131         I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q
    132         S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1
    133         Q
    134         ;
    135 CKSCH   ; -- validate schedule [Called from P-S Action]
    136         N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET)  K ORSD
    137         D EN^PSSGS0(.ORX,$G(ORCAT))
    138         I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q  ;ok
    139         W $C(7),!,"Enter a standard schedule for administering this medication"
    140         K DONE I $G(ORCAT)="I" W ".",! Q
    141         W " or one of your own,",!,"up to 20 characters.",!
    142         Q
    143         ;
    144 DEFCONJ ; -- Set default conjuction for previous instance [P-S Action]
    145         N LAST,DUR,CONJ
    146         S LAST=$O(ORDIALOG(PROMPT,ORI),-1) Q:LAST'>0  ;first instance
    147         S CONJ=$$PTR("AND/THEN") Q:$L($G(ORDIALOG(CONJ,LAST)))
    148         S DUR=$G(ORDIALOG($$PTR("DURATION"),LAST))
    149         S ORDIALOG(CONJ,LAST)=$S(+DUR'>0:"A",1:"T")
    150         Q
    151         ;
    152 ENCONJ  ; -- Get allowable values, if req'd for INST
    153         N P S P=$$PTR("INSTRUCTIONS")
    154         S REQD=$S($O(ORDIALOG(P,INST)):1,1:0)
    155         S ORDIALOG(PROMPT,"A")="And/then"_$S(ORCAT="O":"/except: ",1:": ")
    156         S $P(ORDIALOG(PROMPT,0),U,2)="A:AND;T:THEN;"_$S(ORCAT="O":"X:EXCEPT;",1:"")
    157         Q
    158         ;
    159 DSUP    ; -- Get max/default days supply
    160         N ORX,Y
    161         S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG)
    162         D DSUP^PSOSIGDS(.ORX) S Y=+$G(ORX("DAYS SUPPLY")) S:Y'>0 Y=90
    163         ;S $P(ORDIALOG(PROMPT,0),U,2)="1:"_Y ;max allowed
    164         I '$G(ORDIALOG(PROMPT,1)),$G(ORTYPE)'="Z" S ORDIALOG(PROMPT,1)=Y
    165         Q
    166         ;
    167 QTY()   ; -- Return default quantity [Expects ORDSUP]
    168         N INSTR,DOSE,DUR,SCH,I,ORX,X,Y
    169         S Y="" I $G(ORDSUP)'>0!'$G(ORDRUG) G QTYQ ;need days supply, disp drug
    170         S INSTR=$$PTR("INSTRUCTIONS")
    171         S DOSE=$$PTR("DOSE"),CONJ=$$PTR("AND/THEN")
    172         S DUR=$$PTR("DURATION"),SCH=$$PTR("SCHEDULE")
    173         S I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:I'>0  D  Q:'$D(ORX)
    174         . S X=$P($G(ORDIALOG(DOSE,I)),"&",3) I X'>0 K ORX Q
    175         . S ORX("DOSE ORDERED",I)=X,ORX("SCHEDULE",I)=$G(ORDIALOG(SCH,I))
    176         . S X=$G(ORDIALOG(DUR,I)),ORX("DURATION",I)=$$HL7DUR^ORMBLDPS
    177         . S ORX("CONJUNCTION",I)=$G(ORDIALOG(CONJ,I))
    178         G:'$D(ORX) QTYQ ;no doses
    179         S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG)
    180         S ORX("DAYS SUPPLY")=+$G(ORDSUP)
    181         D QTYX^PSOSIG(.ORX) S Y=$G(ORX("QTY"))
    182 QTYQ    Q Y
    183         ;
    184 MAXREFS ; -- Get max refills allowed [Entry Action]
    185         Q:$G(ORCAT)'="O"  N ORX,X
    186         S ORX("ITEM")=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2)
    187         S ORX("DRUG")=+$G(ORDRUG),ORX("PATIENT")=+$G(ORVP)
    188         I $G(OREVENT),$$TYPE^OREVNTX(OREVENT)="D" S ORX("DISCHARGE")=1
    189         S ORX("DAYS SUPPLY")=$G(ORDSUP) D MAX^PSOSIGDS(.ORX)
    190         S OREFILLS=$G(ORX("MAX")),X=$G(ORDIALOG(PROMPT,INST))
    191         I OREFILLS'>0 S ORDIALOG(PROMPT,INST)=0 W !,"No refills allowed." Q
    192         S $P(ORDIALOG(PROMPT,0),U,2)="0:"_OREFILLS
    193         S ORDIALOG(PROMPT,"A")="Refills (0-"_OREFILLS_"): "
    194         I X,X>OREFILLS S ORDIALOG(PROMPT,INST)=OREFILLS
    195         Q
    196         ;
    197 ASKSC() ; -- Return 1 or 0, if SC prompt should be asked
    198         I $$SC^PSOCP(+ORVP,+$G(ORDRUG)) Q 0
    199         ;I $$RXST^IBARXEU(+ORVP)>0 Q 0 ;exempt from copay
    200         Q 1
    201         ;
    202 PTR(X)  ; -- Return ptr to prompt OR GTX X
    203         Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
    204         ;
    205 EXIT    ; -- exit action for Meds
    206         S:$G(ORXNP) ORNP=ORXNP
    207         K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX
    208         K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    209         Q
     1ORCDPS1 ;SLC/MKB-Pharmacy dialog utilities ; 08 May 2002  2:12 PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,117,141,149,195,215**;Dec 17, 1997
     3 ;
     4 ; DBIA 2418   START^PSSJORDF   ^TMP("PSJMR",$J)
     5 ; DBIA 3166   EN^PSSDIN        ^TMP("PSSDIN",$J)
     6 ;
     7EN(TYPE) ; -- entry action for Meds dialogs
     8 S ORINPT=$$INPT^ORCD,ORCAT=$G(TYPE)
     9 I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location?
     10 I ORCAT="" D
     11 . I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT),$L($P($G(OR0),U,12)) S ORCAT=$P(OR0,U,12) Q  ;use value from order, via ORCACT4
     12 . S ORCAT=$S(ORINPT:"I",1:"O")
     13 S ORDG=+$O(^ORD(100.98,"B",$S(ORCAT="I":"UD RX",1:"O RX"),0))
     14 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     15 I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D  Q:$G(ORQUIT)
     16 . I 'ORINPT,ORCAT="I" D  Q:$G(ORQUIT)
     17 .. N OI S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1
     18 .. I '$O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORQUIT=1 W $C(7),!!,"This order may not be placed at this location!" Q
     19 . K ORDIALOG($$PTR("START DATE/TIME"),1)
     20 . K ORDIALOG($$PTR("NOW"),1) Q:ORCAT'="O"
     21 . I $G(OREDIT)!$G(OREWRITE) N PI S PI=$$PTR("PATIENT INSTRUCTIONS") K ORDIALOG(PI,1),^TMP("ORWORD",$J,PI)
     22 . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J)
     23 I ORINPT,ORCAT="O" W $C(7),!!,"NOTE: This will create an outpatient prescription for an inpatient!",!
     24 Q
     25 ;
     26EN1 ; -- setup Meds dialog for quick order editor using ORDG
     27 N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
     28 I $P(DG," ")="O"!(DG="SPLY") S ORINPT=0,ORCAT="O"
     29 E  S ORINPT=1,ORCAT="I"
     30 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     31 Q
     32 ;
     33ENOI ; -- setup OI prompt
     34 N D S D=$G(ORDIALOG(PROMPT,"D"))
     35 S:D="S.RX" ORDIALOG(PROMPT,"D")=$S(ORCAT="I":"S.UD RX",1:"S.O RX")
     36 I ORCAT="I",'ORINPT,D="S.UD RX" D  ;limit to IV meds for outpt's
     37 . S ORDIALOG(PROMPT,"D")="S.IVM RX" ;ORDG=+$O(^ORD(100.98,"B","O RX",0))
     38 . S ORDIALOG(PROMPT,"?")="Enter the IV medication you wish to order for this patient."
     39 Q
     40 ;
     41DEA ; -- ck DEA# of ordering provider if SchedII drug
     42 Q:$G(ORTYPE)="Z"  N DEAFLG,PSOI
     43 S PSOI=+$P($G(^ORD(101.43,+$G(Y),0)),U,2) Q:PSOI'>0
     44 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,ORCAT) Q:DEAFLG'>0  ;ok
     45 I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" K DONE Q
     46 I DEAFLG=1 W $C(7),!,"This order will require a wet signature!"
     47 Q
     48 ;
     49CHANGED(X) ; -- Kill dependent values when prompt X changes
     50 N PROMPTS,NAME,PTR,P,I
     51 S PROMPTS=X I X="OI" D
     52 . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DURATION^AND/THEN^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS^DAYS SUPPLY^QUANTITY^REFILLS^SERVICE CONNECTED"
     53 . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY
     54 . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     55 I X="DS" S PROMPTS="QUANTITY^REFILLS" K OREFILLS
     56 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
     57 . S PTR=$$PTR(NAME) Q:'PTR
     58 . S I=0 F  S I=$O(ORDIALOG(PTR,I)) Q:I'>0  K ORDIALOG(PTR,I)
     59 . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR)
     60 Q
     61 ;
     62ORDITM(OI) ; -- Check OI, get dependent info
     63 Q:OI'>0  ;quit - no value
     64 N ORPS,ORPSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),ORPSOI=+$P($G(^(0)),U,2)
     65 S ORIV=$S($P(ORPS,U)=2:1,1:0)
     66 I $G(ORCAT)="O",'$P(ORPS,U,2) W $C(7),!,"This drug may not be used in an outpatient order." S ORQUIT=1 D WAIT Q
     67 I $G(ORCAT)="I" D  Q:$G(ORQUIT)
     68 . I $G(ORINPT),'$P(ORPS,U) W $C(7),!,"This drug may not be used in an inpatient order." S ORQUIT=1 D WAIT Q
     69 . I '$G(ORINPT),'ORIV W $C(7),!,"This drug may not be ordered for an outpatient." S ORQUIT=1 D WAIT Q
     70 I $G(ORTYPE)="Q" D  I $G(ORQUIT) D WAIT Q
     71 . N DEAFLG S DEAFLG=$$OIDEA^PSSUTLA1(ORPSOI,ORCAT) Q:DEAFLG'>0  ;ok
     72 . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q
     73 . I DEAFLG=1 W $C(7),!,"This order will require a wet signature!"
     74OI1 ; -ck NF status
     75 I $P(ORPS,U,6),'$G(ORENEW) D  ;alternative
     76 . W !!,"*** This medication is not in the formulary! ***"
     77 . N PSX,CNT,ORX,DIR,X,Y,DTOUT,DUOUT
     78 . D EN1^PSSUTIL1(.ORPSOI,ORCAT) I '$O(ORPSOI(0)) D  Q
     79 .. W !,"    There are no formulary alternatives entered for this item."
     80 .. W !,"    Please consult with your pharmacy before ordering it."
     81 . S PSX=0,CNT=0 F  S PSX=$O(ORPSOI(PSX)) Q:PSX'>0  D
     82 .. S ORX=+$O(^ORD(101.43,"ID",PSX_";99PSP",0)) Q:ORX'>0
     83 .. S CNT=CNT+1,ORPSOI("OI",CNT)=ORX_U_PSX
     84 .. S DIR("A",CNT)=$J(CNT,3)_" "_$P($G(^ORD(101.43,ORX,0)),U)
     85 . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select alternative (or <return> to continue): "
     86 . S DIR("?")="The medication selected is not in the formulary; you may select one of the above listed alternatives instead, or press <return> to continue processing this order."
     87 . Q:CNT'>0  W !,"    Formulary alternatives:" D ^DIR
     88 . I Y'>0 S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 Q
     89 . D:OI'=+ORPSOI("OI",+Y) CHANGED("OI") ;reset parameters if different
     90 . S OI=+ORPSOI("OI",+Y),ORDIALOG(PROMPT,INST)=OI,OROI=OI
     91 . S ORPSOI=+$P(ORPSOI("OI",+Y),U,2)
     92OI2 ; -get routes, doses [also called from NF^ORCDPS]
     93 D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(ORPSOI,$G(ORCAT))  ;DBIA 2418
     94 I '$D(ORDOSE) D
     95 . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,$S($G(ORCAT)="I":"U",1:"O"),+ORVP)
     96 . K:$G(ORDOSE(1))=-1 ORDOSE
     97 Q
     98 ;
     99NFI(OI) ; -- Show NFI restrictions, if exist
     100 N PSOI,I,J,LCNT,MAX,X,STOP
     101 S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2)
     102 D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI))  ;DBIA 3166
     103 S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W !
     104 F  S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0  D
     105 . S J=0 F  S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0  S X=$G(^(J)) D  Q:$G(STOP)
     106 .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP)  S LCNT=1
     107 .. W !,X
     108 W ! K ^TMP("PSSDIN",$J,"OI",PSOI)
     109 Q
     110 ;
     111CONT() ; -- Cont or stop?
     112 N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA"
     113 S DIR("A")="Press <return> to continue or ^ to stop ..."
     114 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
     115 Q +Y
     116 ;
     117WAIT ; -- Wait for user
     118 N X W !,"Press <return> to continue ..." R X:DTIME
     119 Q
     120 ;
     121ROUTES ; -- Get med routes
     122 Q:$G(ORDIALOG(PROMPT,"LIST"))  N I,X,CNT S (I,CNT)=0
     123 F  S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0  S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3)
     124 S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT
     125 S:$G(ORTYPE)'="Z" REQD=$S(ORCAT="I":1,$P($G(^ORD(101.43,+$G(OROI),"PS")),U,5):0,1:1)
     126 Q
     127 ;
     128DEFRTE ; -- Get default route
     129 N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST
     130 I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q
     131 S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1
     132 Q
     133 ;
     134CKSCH ; -- validate schedule [Called from P-S Action]
     135 N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET)  K ORSD
     136 D EN^PSSGS0(.ORX,$G(ORCAT))
     137 I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q  ;ok
     138 W $C(7),!,"Enter a standard administration schedule"
     139 K DONE I $G(ORCAT)="I" W ".",! Q
     140 W " or one of your own,",!,"up to 70 characters and no more than 2 spaces.",!
     141 Q
     142 ;
     143DEFCONJ ; -- Set default conjuction for previous instance [P-S Action]
     144 N LAST,DUR,CONJ
     145 S LAST=$O(ORDIALOG(PROMPT,ORI),-1) Q:LAST'>0  ;first instance
     146 S CONJ=$$PTR("AND/THEN") Q:$L($G(ORDIALOG(CONJ,LAST)))
     147 S DUR=$G(ORDIALOG($$PTR("DURATION"),LAST))
     148 S ORDIALOG(CONJ,LAST)=$S(+DUR'>0:"A",1:"T")
     149 Q
     150 ;
     151ENCONJ ; -- Get allowable values, if req'd for INST
     152 N P S P=$$PTR("INSTRUCTIONS")
     153 S REQD=$S($O(ORDIALOG(P,INST)):1,1:0)
     154 S ORDIALOG(PROMPT,"A")="And/then"_$S(ORCAT="O":"/except: ",1:": ")
     155 S $P(ORDIALOG(PROMPT,0),U,2)="A:AND;T:THEN;"_$S(ORCAT="O":"X:EXCEPT;",1:"")
     156 Q
     157 ;
     158DSUP ; -- Get max/default days supply
     159 N ORX,Y
     160 S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG)
     161 D DSUP^PSOSIGDS(.ORX) S Y=+$G(ORX("DAYS SUPPLY")) S:Y'>0 Y=90
     162 ;S $P(ORDIALOG(PROMPT,0),U,2)="1:"_Y ;max allowed
     163 I '$G(ORDIALOG(PROMPT,1)),$G(ORTYPE)'="Z" S ORDIALOG(PROMPT,1)=Y
     164 Q
     165 ;
     166QTY() ; -- Return default quantity [Expects ORDSUP]
     167 N INSTR,DOSE,DUR,SCH,I,ORX,X,Y
     168 S Y="" I $G(ORDSUP)'>0!'$G(ORDRUG) G QTYQ ;need days supply, disp drug
     169 S INSTR=$$PTR("INSTRUCTIONS")
     170 S DOSE=$$PTR("DOSE"),CONJ=$$PTR("AND/THEN")
     171 S DUR=$$PTR("DURATION"),SCH=$$PTR("SCHEDULE")
     172 S I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:I'>0  D  Q:'$D(ORX)
     173 . S X=$P($G(ORDIALOG(DOSE,I)),"&",3) I X'>0 K ORX Q
     174 . S ORX("DOSE ORDERED",I)=X,ORX("SCHEDULE",I)=$G(ORDIALOG(SCH,I))
     175 . S X=$G(ORDIALOG(DUR,I)),ORX("DURATION",I)=$$HL7DUR^ORMBLDPS
     176 . S ORX("CONJUNCTION",I)=$G(ORDIALOG(CONJ,I))
     177 G:'$D(ORX) QTYQ ;no doses
     178 S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG)
     179 S ORX("DAYS SUPPLY")=+$G(ORDSUP)
     180 D QTYX^PSOSIG(.ORX) S Y=$G(ORX("QTY"))
     181QTYQ Q Y
     182 ;
     183MAXREFS ; -- Get max refills allowed [Entry Action]
     184 Q:$G(ORCAT)'="O"  N ORX,X
     185 S ORX("ITEM")=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2)
     186 S ORX("DRUG")=+$G(ORDRUG),ORX("PATIENT")=+$G(ORVP)
     187 I $G(OREVENT),$$TYPE^OREVNTX(OREVENT)="D" S ORX("DISCHARGE")=1
     188 S ORX("DAYS SUPPLY")=$G(ORDSUP) D MAX^PSOSIGDS(.ORX)
     189 S OREFILLS=$G(ORX("MAX")),X=$G(ORDIALOG(PROMPT,INST))
     190 I OREFILLS'>0 S ORDIALOG(PROMPT,INST)=0 W !,"No refills allowed." Q
     191 S $P(ORDIALOG(PROMPT,0),U,2)="0:"_OREFILLS
     192 S ORDIALOG(PROMPT,"A")="Refills (0-"_OREFILLS_"): "
     193 I X,X>OREFILLS S ORDIALOG(PROMPT,INST)=OREFILLS
     194 Q
     195 ;
     196ASKSC() ; -- Return 1 or 0, if SC prompt should be asked
     197 I $$SC^PSOCP(+ORVP,+$G(ORDRUG)) Q 0
     198 ;I $$RXST^IBARXEU(+ORVP)>0 Q 0 ;exempt from copay
     199 Q 1
     200 ;
     201PTR(X) ; -- Return ptr to prompt OR GTX X
     202 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
     203 ;
     204EXIT ; -- exit action for Meds
     205 S:$G(ORXNP) ORNP=ORXNP
     206 K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX
     207 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     208 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS2.m

    r613 r623  
    1 ORCDPS2 ;SLC/MKB-Pharmacy dialog utilities ;12/14/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,125,131,243**;Dec 17, 1997;Build 242
    3         ;
    4 COMPLEX()       ; -- Single or complex?
    5         N X,Y,DIR,DUOUT,DTOUT,COMPLX
    6         S COMPLX=$S($O(ORDIALOG(PROMPT,"?"),-1)>1:1,$L($G(ORDIALOG($$PTR("DURATION"),1))):1,1:0)
    7         I $G(ORTYPE)="Q",$O(ORDIALOG(PROMPT,0)),FIRST Q COMPLX
    8         I $D(ORENEW)!$D(OREWRITE)!$D(ORXFER)!COMPLX Q COMPLX
    9         I $D(OREDIT) Q:$D(ORCOMPLX)!COMPLX COMPLX G CP1 ;Q if complex or 'first, else ask
    10         I 'FIRST S Y=$S($D(ORCOMPLX):ORCOMPLX,1:COMPLX) Q Y
    11 CP1     S DIR(0)="YA",DIR("A")="Complex dose? ",DIR("B")="NO"
    12         S DIR("?")="Enter YES if you wish to enter multiple sets of dosage instructions, a tapering dose, or to limit the duration of a single dose."
    13         D ^DIR S:$D(DTOUT) Y="^"
    14         Q Y
    15         ;
    16 DOSES   ; -- Available common doses
    17         ;S $P(ORDIALOG(PROMPT,0),U,2)=$S(ORCAT="I":"1:20",1:"1:80")
    18         S ORDIALOG(PROMPT,"A")="Dose"_$S(ORCAT="I"&$G(ORIV):" or Rate: ",1:": ")
    19         S $P(ORDIALOG(PROMPT,"?"),",",2)=$S($G(ORIV):" as either a dose amount or infusion rate.",1:" as a dose or amount.")
    20         I FIRST,'$O(ORDIALOG(PROMPT,0)),$G(ORXFER) D SHOWSIG^ORCMED
    21         S ORCOMPLX=$$COMPLEX,MULT=+ORCOMPLX I ORCOMPLX="^" S ORQUIT=1 Q
    22         Q:$G(ORDIALOG(PROMPT,"LIST"))  Q:'$D(ORDOSE)
    23 D1      ; -- Entry from ORCMED,NF^ORCDPS to build list
    24         N I,J,X,DD,DRUG,DOSE,CONJ,CNT,UD,COST,TEXT
    25         S (I,CNT)=0,CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ
    26         F  S I=$O(ORDOSE(I)) Q:I'>0  D
    27         . S X=ORDOSE(I),DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD)
    28         . ;  =TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN^Cost
    29         . ;DD=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills?
    30         . S DOSE=$P(X,U,5),UD=$P(X,U,3),COST=$P(X,U,7) Q:'$L(DOSE)
    31         . I '$P(X,U) S DOSE=DOSE_CONJ_" "_$S($L($P(DRUG,U,5)):$P(DRUG,U,5)_$P(DRUG,U,6),1:$P(DRUG,U))
    32         . ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4)
    33         . S TEXT=DOSE_$S($L(COST):"     $"_COST,1:"")_$S($P(DRUG,U,3):"   (non-formulary)",1:"")
    34         . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DOSE_U_TEXT
    35         . S ORDIALOG(PROMPT,"LIST","B",TEXT)=DOSE
    36         . S ORDIALOG(PROMPT,"LIST","D",DOSE)=DD ;default DispDrug
    37         . S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I),U,1,6)_U_$P(DRUG,U,5,6)
    38         . S J=0 F  S J=$O(ORDOSE(I,J)) Q:J'>0  D  ;xref alt forms of dose
    39         .. S DD=+$P(ORDOSE(I,J),U,6),DRUG=$G(ORDOSE("DD",DD))
    40         .. S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I,J),U,1,6)_U_$P(DRUG,U,5,6)
    41         S:CNT ORDIALOG(PROMPT,"LIST")=CNT
    42         Q
    43         ;
    44 CHDOSE  ; -- Kill dependent values if inst ORI of dose changes
    45         N X,PROMPTS,P,NAME,DOSE,DD S X=$G(ORDIALOG(PROMPT,ORI))
    46         S X=$$UP^XLFSTR(X),ORDIALOG(PROMPT,ORI)=X ;force uppercase
    47         I X,X'?1.N.E1.A.E K DONE W $C(7),!,"Enter the amount of this drug that the patient is to receive as a dose,",!,"NOT as the number of units per dose." Q
    48         I $L(X)>60,'$D(ORDIALOG(PROMPT,"LIST","B",X)) K DONE W $C(7),!,"Instructions may not be longer than 60 characters." Q
    49         I $G(ORESET)'=X D  ;kill dependent values if new/changed dose
    50         . S PROMPTS="STRENGTH^DRUG NAME^DOSE^DISPENSE DRUG^DAYS SUPPLY^QUANTITY^REFILLS"
    51         . F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) K ORDIALOG($$PTR(NAME),ORI)
    52         . K ORQTY,ORQTYUNT,ORDRUG,ORDIALOG($$PTR("DISPENSE DRUG"),1)
    53         . K ^TMP("ORWORD",$J,$$PTR("SIG"))
    54         S DOSE=$$PTR("DOSE") I $L(X),'$L($G(ORDIALOG(DOSE,ORI))) D  ;set ID
    55         . S DD=+$G(ORDIALOG(PROMPT,"LIST","D",X))
    56         . S:DD ORDIALOG(DOSE,ORI)=$TR($G(ORDOSE("DD",DD,X)),"^","&")
    57         S DD=+$P($G(ORDIALOG(DOSE,ORI)),"&",6)
    58         I DD,$P($G(ORDOSE("DD",DD)),U,3) D NF^ORCDPS(DD) ;look for FormAlt
    59         Q
    60         ;
    61 EXDOSE  ; -- Exit Action
    62         Q:'$O(ORDIALOG(PROMPT,0))  N DRUG,MISC,QUIT,LAST
    63         S ORDRUG=$$DISPDRUG^ORCDPS,DRUG=$G(ORDOSE("DD",+ORDRUG))
    64         I ORDRUG D  I $G(QUIT) S ORQUIT=1 Q
    65         . ;I $P(DRUG,U,10),'$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S QUIT=1 Q
    66         . ;I $P(DRUG,U,10)=1 W $C(7),!,"This order will require a wet signature!"
    67         . S ORDIALOG($$PTR("DISPENSE DRUG"),1)=ORDRUG
    68         . D:$G(ORCAT)="O" RESETID^ORCDPS
    69         . N STR,MED S STR=$P(DRUG,U,5)_$P(DRUG,U,6)
    70         . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG,U) Q
    71         . S MED=$P($G(^ORD(101.43,+$G(OROI),0)),U)
    72         . I MED'[STR,ORCAT="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR
    73         I +ORDRUG'>0,ORCAT="O" W $C(7),!,"Cannot determine dispense drug - some defaults and order checks may not occur!"
    74 EXD1    ; -- Kill dangling conjunction, [re]build Sig, get Qty info
    75         S LAST=$O(ORDIALOG(PROMPT,"?"),-1) K ORDIALOG($$PTR("AND/THEN"),LAST)
    76         D ADMIN^ORCDPS3 D:$G(ORTYPE)'="Z" SIG ;[re]build Sig/Text
    77         I ORDRUG,ORCAT="O" D  ;set Qty info
    78         . S:$L($P(DRUG,U,4)) ORQTYUNT=$P(DRUG,U,4)
    79         . S MISC=$$ENDCM^PSJORUTL(+ORDRUG),ORQTY=$P(MISC,U,4)
    80         . W:$L($P(MISC,U,2)) !!,$P(MISC,U,2),!
    81         Q
    82         ;
    83 SIG     ; -- Create ORDIALOG(SIG) from Instructions PROMPT,ORDOSE,ORDRUG,ORCAT
    84         ;    Return text in ^TMP("ORWORD",$J,SIG,INST)
    85         ;   [also called from PSJ^ORCSEND1 to build child orders]
    86         ;
    87         N ORT,ORSCH,ORDUR,ORID,ORDD,ORCNJ,ORMISC,ORPREP,ORX,ORI,CNT,ORSIG,ORS,DOSE
    88         S ORT=$$PTR("ROUTE"),ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION")
    89         S ORID=$$PTR("DOSE"),ORCNJ=$$PTR("AND/THEN"),ORS=$$PTR("SIG")
    90         S ORMISC=$G(ORDOSE("MISC")),ORPREP=$P(ORMISC,U,2)
    91         S ORX=$S(ORCAT="I":"",ORCAT="O"&(+$G(ISIMO)=1):"",$L($P(ORMISC,U)):$P(ORMISC,U)_" ",1:"") ;"TAKE "
    92         S (CNT,ORI)=0 F  S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0  D
    93         . S DOSE=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(DOSE)
    94         . S ORX=ORX_$$DOSE_$$RTE_$$SCH_$$DUR_$$CONJ
    95         . S CNT=CNT+1,ORSIG(CNT,0)=ORX,ORX=""
    96         Q:CNT'>0  S ORSIG(0)="^^"_CNT_U_CNT_U_DT_U
    97         K ^TMP("ORWORD",$J,ORS,1) M ^(1)=ORSIG S ORDIALOG(PROMPT,"FORMAT")="@"
    98         S ORDIALOG(ORS,1)=$NA(^TMP("ORWORD",$J,ORS,1))
    99         Q
    100         ;
    101 PTR(X)  ; -- Ptr to prompt OR GTX X
    102         Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
    103         ;
    104 DOSE()  ; -- Dosage
    105         N X0,Y S X0=$G(ORDIALOG(ORID,ORI)) ;ID string
    106         S Y=DOSE I ORDRUG,$L(X0) D  ;use local dose if common DispDrug
    107         . S:$L($P(X0,"&",5)) Y=$P(X0,"&",5) ;unless Outpt w/total dose
    108         . I ORCAT="O",X0 S Y=$$WORD($P(X0,"&",3))_" "_$P(X0,"&",4) ;u/d
    109         Q Y
    110         ;
    111 WORD(X) ; -- Words for number X
    112         N X1,X2,Y S X1=$P(+X,"."),X2=$P(+X,".",2)
    113         S Y="" I X1 S Y=$S(X1=1:"ONE",X1=2:"TWO",X1=3:"THREE",X1=4:"FOUR",X1=5:"FIVE",X1=6:"SIX",X1=7:"SEVEN",X1=8:"EIGHT",X1=9:"NINE",X1=10:"TEN",1:X1)
    114         I X2 S Y=Y_$S($L(Y):" AND ",1:"")_$S(X2=5:"ONE-HALF",X2=33!(X2=34):"ONE-THIRD",X2=25:"ONE-FOURTH",X2=66!(X2=67):"TWO-THIRDS",X2=75:"THREE-FOURTHS",1:"."_X2)
    115         Q Y
    116         ;
    117 RTE()   ; -- Expansion of route
    118         N X,X0,Y S X=+$G(ORDIALOG(ORT,ORI)) Q:X'>0 ""
    119         K ^TMP($J,"ORCDPS2 RTE")
    120         D ALL^PSS51P2(+X,,,,"ORCDPS2 RTE")
    121         ;S X0=$G(^PS(51.2,+X,0)),Y=""
    122         I ORCAT="I"!(+$G(ISIMO)=1) S Y=" "_$S($L(^TMP($J,"ORCDPS2 RTE",+X,1)):^TMP($J,"ORCDPS2 RTE",+X,1),1:^TMP($J,"ORCDPS2 RTE",+X,.01))
    123         ;I ORCAT="I" S Y=" "_$S($L($P(X0,U,3)):$P(X0,U,3),1:$P(X0,U))
    124         I ORCAT="O",'+$G(ISIMO) S Y=" "_$S($L(ORPREP):ORPREP_" ",1:"")_$S($L(^TMP($J,"ORCDPS2 RTE",+X,4)):^TMP($J,"ORCDPS2 RTE",+X,4),1:^TMP($J,"ORCDPS2 RTE",+X,.01))
    125         Q Y
    126         ;
    127 SCH()   ; -- [outpatient] expansion of schedule
    128         N X,Y S X=$G(ORDIALOG(ORSCH,ORI))
    129         I $L(X),ORCAT="O",'+$G(ISIMO) D SCH^PSSUTIL1(.X)
    130         S Y=$S($L(X):" "_X,1:"")
    131         Q Y
    132         ;
    133 DUR()   ; -- Duration
    134         N X,Y S X=$G(ORDIALOG(ORDUR,ORI)),Y=""
    135         I X S Y=" FOR "_$$UP^XLFSTR(X)_$S(+X=X:" DAYS",1:"")
    136         Q Y
    137         ;
    138 CONJ()  ; -- Conjunction
    139         N X,Y S X=$G(ORDIALOG(ORCNJ,ORI))
    140         S:$L(X)>1 X=$E(X) S:X="E" S="X"
    141         S Y=$S(X="T":", THEN",X="X":" EXCEPT",X="A":" AND",1:"")
    142         Q Y
    143         ;
    144 DOSETEXT               ; -- Reset dose text in ORDIALOG(INSTR) for backdoor orders
    145         ;    [Called from ORMPS1 - uses ORCAT,PSOI,ORVP,DRUG,INSTR,DOSE]
    146         ;
    147         N ORTYPE,ORDOSE,CONJ,ORDRUG,DRUG0,STRG,ORI,LDOSE,X,PROMPT
    148         S ORTYPE=$S($G(ORCAT)="I":"U",1:"O")
    149         D DOSE^PSSORUTL(.ORDOSE,+PSOI,ORTYPE,+ORVP)
    150         S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ
    151         S ORDRUG=+$G(ORDIALOG(DRUG,1)),DRUG0=$G(ORDOSE("DD",ORDRUG))
    152         S STRG=$P(DRUG0,U,5)_$P(DRUG0,U,6)
    153         I '$G(ORDOSE(1)) S ORI=0 F  S ORI=$O(ORDIALOG(INSTR,ORI)) Q:ORI'>0  D
    154         . S LDOSE=$G(ORDIALOG(INSTR,ORI)),X=$G(ORDIALOG(DOSE,ORI)) Q:'$L(X)
    155         . S:'X ORDIALOG(INSTR,ORI)=LDOSE_CONJ_" "_$S(STRG:STRG,1:$P(DRUG0,U))
    156         ; -build Sig/Text if not defined
    157         I '$D(ORDIALOG(+$$PTR("SIG"),1)) S PROMPT=INSTR D SIG
    158         Q
    159         ;
    160 PI      ; -- Include Pt Instructions w/Sig in Outpt order?
    161         N X,Y,DIR,DUOUT,DTOUT,DIRUT,ORTX,ORMAX,I,CNT
    162         I $G(ORCAT)'="O" D CLEARWP Q  ;!'$O(ORDOSE("PI",0))
    163         Q:$G(ORENEW)  S I=0,ORMAX=57
    164         I $G(OREDIT)!$G(OREWRITE),$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ORDOSE("PI") S I=0 F  S I=$O(^TMP("ORWORD",$J,PROMPT,INST,I)) Q:I<1  S ORDOSE("PI",I)=$G(^(I,0))
    165         I '$O(ORDOSE("PI",0)) D CLEARWP Q
    166         F  S I=$O(ORDOSE("PI",I)) Q:I'>0  S X=ORDOSE("PI",I) D TXT^ORCHTAB
    167         S DIR(0)="YA",DIR("A")="Include Patient Instructions in Sig? "
    168         S DIR("?")="Enter NO if you do not want these instructions included in the sig for this order",DIR("B")=$S($D(^TMP("ORWORD",$J,PROMPT)):"YES",1:"NO")
    169         W ! S I=0 F  S I=$O(ORTX(I)) Q:I'>0  W !,$S(I=1:"Patient Instructions: ",1:"                      ")_ORTX(I)
    170         D ^DIR I $D(DUOUT)!$D(DTOUT) S ORQUIT=1 Q
    171         I Y D  Q  ;save text
    172         . K ^TMP("ORWORD",$J,PROMPT,INST) S CNT=0
    173         . S I=0 F  S I=$O(ORDOSE("PI",I)) Q:I'>0  S ^TMP("ORWORD",$J,PROMPT,INST,I,0)=ORDOSE("PI",I),CNT=CNT+1
    174         . S ^TMP("ORWORD",$J,PROMPT,INST,0)="^^"_CNT_U_CNT_U_DT_U
    175         . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
    176         I Y'>0 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST)
    177         Q
    178         ;
    179 CLEARWP ; -- Clear INST of wp field PROMPT
    180         K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST)
    181         Q
     1ORCDPS2 ;SLC/MKB-Pharmacy dialog utilities ;07:24 AM  5 Apr 2001 [12/31/01 6:35pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,125,131**;Dec 17, 1997
     3 ;
     4COMPLEX() ; -- Single or complex dose?
     5 N X,Y,DIR,DUOUT,DTOUT,COMPLX
     6 S COMPLX=$S($O(ORDIALOG(PROMPT,"?"),-1)>1:1,$L($G(ORDIALOG($$PTR("DURATION"),1))):1,1:0)
     7 I $G(ORTYPE)="Q",$O(ORDIALOG(PROMPT,0)),FIRST Q COMPLX
     8 I $D(ORENEW)!$D(OREWRITE)!$D(ORXFER)!COMPLX Q COMPLX
     9 I $D(OREDIT) Q:$D(ORCOMPLX)!COMPLX COMPLX G CP1 ;Q if complex or 'first, else ask
     10 I 'FIRST S Y=$S($D(ORCOMPLX):ORCOMPLX,1:COMPLX) Q Y
     11CP1 S DIR(0)="YA",DIR("A")="Complex dose? ",DIR("B")="NO"
     12 S DIR("?")="Enter YES if you wish to enter multiple sets of dosage instructions, a tapering dose, or to limit the duration of a single dose."
     13 D ^DIR S:$D(DTOUT) Y="^"
     14 Q Y
     15 ;
     16DOSES ; -- Get available common doses
     17 ;S $P(ORDIALOG(PROMPT,0),U,2)=$S(ORCAT="I":"1:20",1:"1:80")
     18 S ORDIALOG(PROMPT,"A")="Dose"_$S(ORCAT="I"&$G(ORIV):" or Rate: ",1:": ")
     19 S $P(ORDIALOG(PROMPT,"?"),",",2)=$S($G(ORIV):" as either a dose amount or infusion rate.",1:" as a dose or amount.")
     20 I FIRST,'$O(ORDIALOG(PROMPT,0)),$G(ORXFER) D SHOWSIG^ORCMED
     21 S ORCOMPLX=$$COMPLEX,MULT=+ORCOMPLX I ORCOMPLX="^" S ORQUIT=1 Q
     22 Q:$G(ORDIALOG(PROMPT,"LIST"))  Q:'$D(ORDOSE)
     23D1 ; -- enter here from ORCMED,NF^ORCDPS to build list
     24 N I,J,X,DD,DRUG,DOSE,CONJ,CNT,UD,COST,TEXT
     25 S (I,CNT)=0,CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ
     26 F  S I=$O(ORDOSE(I)) Q:I'>0  D
     27 . S X=ORDOSE(I),DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD)
     28 . ;  =TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN^Cost
     29 . ;DD=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills?
     30 . S DOSE=$P(X,U,5),UD=$P(X,U,3),COST=$P(X,U,7) Q:'$L(DOSE)
     31 . I '$P(X,U) S DOSE=DOSE_CONJ_" "_$S($L($P(DRUG,U,5)):$P(DRUG,U,5)_$P(DRUG,U,6),1:$P(DRUG,U))
     32 . ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4)
     33 . S TEXT=DOSE_$S($L(COST):"     $"_COST,1:"")_$S($P(DRUG,U,3):"   (non-formulary)",1:"")
     34 . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DOSE_U_TEXT
     35 . S ORDIALOG(PROMPT,"LIST","B",TEXT)=DOSE
     36 . S ORDIALOG(PROMPT,"LIST","D",DOSE)=DD ;default DispDrug
     37 . S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I),U,1,6)_U_$P(DRUG,U,5,6)
     38 . S J=0 F  S J=$O(ORDOSE(I,J)) Q:J'>0  D  ;xref alt forms of dose
     39 .. S DD=+$P(ORDOSE(I,J),U,6),DRUG=$G(ORDOSE("DD",DD))
     40 .. S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I,J),U,1,6)_U_$P(DRUG,U,5,6)
     41 S:CNT ORDIALOG(PROMPT,"LIST")=CNT
     42 Q
     43 ;
     44CHDOSE ; -- kill dependent values if inst ORI of dose changes
     45 N X,PROMPTS,P,NAME,DOSE,DD S X=$G(ORDIALOG(PROMPT,ORI))
     46 S X=$$UP^XLFSTR(X),ORDIALOG(PROMPT,ORI)=X ;force uppercase
     47 I X,X'?1.N.E1.A.E K DONE W $C(7),!,"Enter the amount of this drug that the patient is to receive as a dose,",!,"NOT as the number of units per dose." Q
     48 I $L(X)>60,'$D(ORDIALOG(PROMPT,"LIST","B",X)) K DONE W $C(7),!,"Instructions may not be longer than 60 characters." Q
     49 I $G(ORESET)'=X D  ;kill dependent values if new/changed dose
     50 . S PROMPTS="STRENGTH^DRUG NAME^DOSE^DISPENSE DRUG^DAYS SUPPLY^QUANTITY^REFILLS"
     51 . F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) K ORDIALOG($$PTR(NAME),ORI)
     52 . K ORQTY,ORQTYUNT,ORDRUG,ORDIALOG($$PTR("DISPENSE DRUG"),1)
     53 . K ^TMP("ORWORD",$J,$$PTR("SIG"))
     54 S DOSE=$$PTR("DOSE") I $L(X),'$L($G(ORDIALOG(DOSE,ORI))) D  ;set ID
     55 . S DD=+$G(ORDIALOG(PROMPT,"LIST","D",X))
     56 . S:DD ORDIALOG(DOSE,ORI)=$TR($G(ORDOSE("DD",DD,X)),"^","&")
     57 S DD=+$P($G(ORDIALOG(DOSE,ORI)),"&",6)
     58 I DD,$P($G(ORDOSE("DD",DD)),U,3) D NF^ORCDPS(DD) ;look for FormAlt
     59 Q
     60 ;
     61EXDOSE ; -- Dose Exit Action
     62 Q:'$O(ORDIALOG(PROMPT,0))  N DRUG,MISC,QUIT,LAST
     63 S ORDRUG=$$DISPDRUG^ORCDPS,DRUG=$G(ORDOSE("DD",+ORDRUG))
     64 I ORDRUG D  I $G(QUIT) S ORQUIT=1 Q
     65 . ;I $P(DRUG,U,10),'$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S QUIT=1 Q
     66 . ;I $P(DRUG,U,10)=1 W $C(7),!,"This order will require a wet signature!"
     67 . S ORDIALOG($$PTR("DISPENSE DRUG"),1)=ORDRUG
     68 . D:$G(ORCAT)="O" RESETID^ORCDPS
     69 . N STR,MED S STR=$P(DRUG,U,5)_$P(DRUG,U,6)
     70 . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG,U) Q
     71 . S MED=$P($G(^ORD(101.43,+$G(OROI),0)),U)
     72 . I MED'[STR,ORCAT="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR
     73 I +ORDRUG'>0,ORCAT="O" W $C(7),!,"Cannot determine dispense drug - some defaults and order checks may not occur!"
     74EXD1 ; -kill dangling conjunction, [re]build Sig, get Qty info
     75 S LAST=$O(ORDIALOG(PROMPT,"?"),-1) K ORDIALOG($$PTR("AND/THEN"),LAST)
     76 D ADMIN^ORCDPS3 D:$G(ORTYPE)'="Z" SIG ;[re]build Sig/Text
     77 I ORDRUG,ORCAT="O" D  ;set Qty info
     78 . S:$L($P(DRUG,U,4)) ORQTYUNT=$P(DRUG,U,4)
     79 . S MISC=$$ENDCM^PSJORUTL(+ORDRUG),ORQTY=$P(MISC,U,4)
     80 . W:$L($P(MISC,U,2)) !!,$P(MISC,U,2),!
     81 Q
     82 ;
     83SIG ; -- Create ORDIALOG(SIG) from Instructions PROMPT,ORDOSE,ORDRUG,ORCAT
     84 ;    Return text in ^TMP("ORWORD",$J,SIG,INST)
     85 ;   [also called from PSJ^ORCSEND1 to build child orders]
     86 ;
     87 N ORT,ORSCH,ORDUR,ORID,ORDD,ORCNJ,ORMISC,ORPREP,ORX,ORI,CNT,ORSIG,ORS,DOSE
     88 S ORT=$$PTR("ROUTE"),ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION")
     89 S ORID=$$PTR("DOSE"),ORCNJ=$$PTR("AND/THEN"),ORS=$$PTR("SIG")
     90 S ORMISC=$G(ORDOSE("MISC")),ORPREP=$P(ORMISC,U,2)
     91 S ORX=$S(ORCAT="I":"",$L($P(ORMISC,U)):$P(ORMISC,U)_" ",1:"") ;"TAKE "
     92 S (CNT,ORI)=0 F  S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0  D
     93 . S DOSE=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(DOSE)
     94 . S ORX=ORX_$$DOSE_$$RTE_$$SCH_$$DUR_$$CONJ
     95 . S CNT=CNT+1,ORSIG(CNT,0)=ORX,ORX=""
     96 Q:CNT'>0  S ORSIG(0)="^^"_CNT_U_CNT_U_DT_U
     97 K ^TMP("ORWORD",$J,ORS,1) M ^(1)=ORSIG S ORDIALOG(PROMPT,"FORMAT")="@"
     98 S ORDIALOG(ORS,1)=$NA(^TMP("ORWORD",$J,ORS,1))
     99 Q
     100 ;
     101PTR(X) ; -- Return ptr to prompt OR GTX X
     102 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
     103 ;
     104DOSE() ; -- Return dosage
     105 N X0,Y S X0=$G(ORDIALOG(ORID,ORI)) ;ID string
     106 S Y=DOSE I ORDRUG,$L(X0) D  ;use local dose if common DispDrug
     107 . S:$L($P(X0,"&",5)) Y=$P(X0,"&",5) ;unless Outpt w/total dose
     108 . I ORCAT="O",X0 S Y=$$WORD($P(X0,"&",3))_" "_$P(X0,"&",4) ;u/d
     109 Q Y
     110 ;
     111WORD(X) ; -- Return words for number X
     112 N X1,X2,Y S X1=$P(+X,"."),X2=$P(+X,".",2)
     113 S Y="" I X1 S Y=$S(X1=1:"ONE",X1=2:"TWO",X1=3:"THREE",X1=4:"FOUR",X1=5:"FIVE",X1=6:"SIX",X1=7:"SEVEN",X1=8:"EIGHT",X1=9:"NINE",X1=10:"TEN",1:X1)
     114 I X2 S Y=Y_$S($L(Y):" AND ",1:"")_$S(X2=5:"ONE-HALF",X2=33!(X2=34):"ONE-THIRD",X2=25:"ONE-FOURTH",X2=66!(X2=67):"TWO-THIRDS",X2=75:"THREE-FOURTHS",1:"."_X2)
     115 Q Y
     116 ;
     117RTE() ; -- Return expansion of route
     118 N X,X0,Y S X=+$G(ORDIALOG(ORT,ORI)) Q:X'>0 ""
     119 S X0=$G(^PS(51.2,+X,0)),Y=""
     120 I ORCAT="I" S Y=" "_$S($L($P(X0,U,3)):$P(X0,U,3),1:$P(X0,U))
     121 I ORCAT="O" S Y=" "_$S($L(ORPREP):ORPREP_" ",1:"")_$S($L($P(X0,U,2)):$P(X0,U,2),1:$P(X0,U))
     122 Q Y
     123 ;
     124SCH() ; -- Return [outpatient] expansion of schedule
     125 N X,Y S X=$G(ORDIALOG(ORSCH,ORI))
     126 I $L(X),ORCAT="O" D SCH^PSSUTIL1(.X)
     127 S Y=$S($L(X):" "_X,1:"")
     128 Q Y
     129 ;
     130DUR() ; -- Return duration
     131 N X,Y S X=$G(ORDIALOG(ORDUR,ORI)),Y=""
     132 I X S Y=" FOR "_$$UP^XLFSTR(X)_$S(+X=X:" DAYS",1:"")
     133 Q Y
     134 ;
     135CONJ() ; -- Return conjuction
     136 N X,Y S X=$G(ORDIALOG(ORCNJ,ORI))
     137 S:$L(X)>1 X=$E(X) S:X="E" S="X"
     138 S Y=$S(X="T":", THEN",X="X":" EXCEPT",X="A":" AND",1:"")
     139 Q Y
     140 ;
     141DOSETEXT        ; -- Reset dose text in ORDIALOG(INSTR) for backdoor orders
     142 ;    [Called from ORMPS1 - uses ORCAT,PSOI,ORVP,DRUG,INSTR,DOSE]
     143 ;
     144 N ORTYPE,ORDOSE,CONJ,ORDRUG,DRUG0,STRG,ORI,LDOSE,X,PROMPT
     145 S ORTYPE=$S($G(ORCAT)="I":"U",1:"O")
     146 D DOSE^PSSORUTL(.ORDOSE,+PSOI,ORTYPE,+ORVP)
     147 S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ
     148 S ORDRUG=+$G(ORDIALOG(DRUG,1)),DRUG0=$G(ORDOSE("DD",ORDRUG))
     149 S STRG=$P(DRUG0,U,5)_$P(DRUG0,U,6)
     150 I '$G(ORDOSE(1)) S ORI=0 F  S ORI=$O(ORDIALOG(INSTR,ORI)) Q:ORI'>0  D
     151 . S LDOSE=$G(ORDIALOG(INSTR,ORI)),X=$G(ORDIALOG(DOSE,ORI)) Q:'$L(X)
     152 . S:'X ORDIALOG(INSTR,ORI)=LDOSE_CONJ_" "_$S(STRG:STRG,1:$P(DRUG0,U))
     153 ; -build Sig/Text if not defined
     154 I '$D(ORDIALOG(+$$PTR("SIG"),1)) S PROMPT=INSTR D SIG
     155 Q
     156 ;
     157PI ; -- Include Patient Instructions w/Sig in Outpt order?
     158 N X,Y,DIR,DUOUT,DTOUT,DIRUT,ORTX,ORMAX,I,CNT
     159 I $G(ORCAT)'="O" D CLEARWP Q  ;!'$O(ORDOSE("PI",0))
     160 Q:$G(ORENEW)  S I=0,ORMAX=57
     161 I $G(OREDIT)!$G(OREWRITE),$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ORDOSE("PI") S I=0 F  S I=$O(^TMP("ORWORD",$J,PROMPT,INST,I)) Q:I<1  S ORDOSE("PI",I)=$G(^(I,0))
     162 I '$O(ORDOSE("PI",0)) D CLEARWP Q
     163 F  S I=$O(ORDOSE("PI",I)) Q:I'>0  S X=ORDOSE("PI",I) D TXT^ORCHTAB
     164 S DIR(0)="YA",DIR("A")="Include Patient Instructions in Sig? "
     165 S DIR("?")="Enter NO if you do not want these instructions included in the sig for this order",DIR("B")="YES"
     166 W ! S I=0 F  S I=$O(ORTX(I)) Q:I'>0  W !,$S(I=1:"Patient Instructions: ",1:"                      ")_ORTX(I)
     167 D ^DIR I $D(DUOUT)!$D(DTOUT) S ORQUIT=1 Q
     168 I Y D  Q  ;save text
     169 . K ^TMP("ORWORD",$J,PROMPT,INST) S CNT=0
     170 . S I=0 F  S I=$O(ORDOSE("PI",I)) Q:I'>0  S ^TMP("ORWORD",$J,PROMPT,INST,I,0)=ORDOSE("PI",I),CNT=CNT+1
     171 . S ^TMP("ORWORD",$J,PROMPT,INST,0)="^^"_CNT_U_CNT_U_DT_U
     172 . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
     173 I Y'>0 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST)
     174 Q
     175 ;
     176CLEARWP ; -- Clear INST of wp field PROMPT
     177 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST)
     178 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS3.m

    r613 r623  
    1 ORCDPS3 ;SLC/MKB-Pharmacy dialog utilities ;09/11/07
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,158,149,190,277,243**;Dec 17, 1997;Build 242
    3         ;
    4 START   ; -- Start Date entry action
    5         S $P(ORDIALOG(PROMPT,0),":",3)=$S($G(ORCAT)="I":"ETRX",1:"EX")
    6         I $G(ORCAT)'="I" K ORSD K:$G(ORENEW)!$G(OREWRITE)!$D(OREDIT) ORDIALOG(PROMPT,INST) ;Inpt only
    7         Q
    8         ;
    9 ADMIN   ; -- Return default admin time for order in ORSD
    10         ;    Called from EXDOSE^ORCDPS2
    11         Q:$D(ORSD)  Q:$G(ORCAT)'="I"  ;inpt only
    12         N PSOI,PSIFN,SCH,CNJ,ORI,ORX
    13         S PSOI=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2)
    14         S PSIFN=$S($G(ORENEW):$G(^OR(100,+$G(ORIFN),4)),1:"")
    15         S SCH=$$PTR^ORCD("OR GTX SCHEDULE"),CNJ=$$PTR^ORCD("OR GTX AND/THEN"),ORX=""
    16         S ORI=0 F  S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1  S ORX=ORX_$S($L(ORX):U,1:"")_$G(ORDIALOG(CNJ,ORI))_";"_$G(ORDIALOG(SCH,ORI))
    17         S ORSD=$$FIRST(+ORVP,+$G(ORWARD),PSOI,ORX,PSIFN,"")
    18         S:$P(ORSD,U)="NEXT" ORSD="NEXTA^"_$P(ORSD,U,2,99)
    19         Q
    20         ;
    21 FIRST(DFN,WARD,OI,DATA,ORDER,ADMIN)       ; -- Return expected first admin time of order
    22         N CNT,ORCNT,ORI,J,ORZ,Y,SCH,ORX,TNUM
    23         I '$G(DFN)!'$G(OI) Q ""
    24         S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D  Q:$E(ORZ)="T"
    25         .S TNUM=$$NUMCHAR(ORZ,";") Q:TNUM=0
    26         .F CNT=1:1:TNUM D
    27         .. S SCH=$P(ORZ,";",CNT+1) Q:'$L(SCH)  S ORCNT=ORCNT+1
    28         .. I ORCNT>1 S ADMIN=""
    29         .. S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER),$G(ADMIN))
    30         S Y=9999999,J=0
    31         F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ<Y S Y=ORZ,J=ORI ;earliest
    32         S Y=$S(J:ORX(J),1:"")
    33         Q Y
    34         ;
    35 NUMCHAR(STRING,SUB)     ;
    36         N CNT,RESULT
    37         S RESULT=0
    38         F CNT=1:1:$L(STRING) I $E(STRING,CNT)=SUB S RESULT=RESULT+1
    39         Q RESULT
    40         ;
    41 NOW     ; -- First dose now?
    42         N X,Y,DIR,SCH
    43         K ^TMP($J,"ORCDPS3 NOW")
    44         I $G(ORCAT)="O"!'$D(ORSD)!$L($G(OREVENT))!$G(ORENEW) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q
    45         D AP^PSS51P1("PSJ",,,,"ORCDPS3 NOW")
    46         ; ask on Copy? Change?
    47         S X=$$PTR^ORCD("OR GTX SCHEDULE"),Y=+$O(ORDIALOG(X,0))
    48         S SCH=$G(ORDIALOG(X,Y)),Y=+$O(^TMP($J,"ORCDPS3 NOW","APPSJ",SCH,0)) ;1st one
    49         ;S SCH=$G(ORDIALOG(X,Y)),Y=+$O(^PS(51.1,"APPSJ",SCH,0)) ;1st one
    50         I $G(^TMP($J,"ORCDPS3 NOW",SCH,5))=""!(Y<1) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q
    51         ;I $P($G(^PS(51.1,Y,0)),U,5)="O"!(Y<1) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q
    52         ; other conditions?
    53         S DIR(0)="YA",DIR("A")="Give additional dose NOW? "
    54         S DIR("B")=$S($G(ORDIALOG(PROMPT,INST)):"YES",1:"NO")
    55         I ORINPT,$P(ORSD,U,4) S DIR("A",1)="Next scheduled administration time: "_$$FMTE^XLFDT($P(ORSD,U,4))
    56         S DIR("?")="Enter YES if you want a dose given now in addition to the regular administration times for this schedule and ward."
    57         D ^DIR S:$D(DTOUT)!$D(DUOUT) ORQUIT=1
    58         I $G(ORQUIT)!(Y'>0) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q
    59         S ORDIALOG(PROMPT,INST)=1 I $G(ORCOMPLX) D
    60         . W $C(7),!,"  >> First Dose NOW is in addition to those already entered.    <<"
    61         . W !,"  >> Please adjust the duration of the first one, if necessary. <<"
    62         K ^TMP($J,"ORCDPS3 NOW")
    63         Q
    64         ;
    65 DEFSTRT ; -- Returns default start date/time in Y
    66         ;    Expects PROMPT,INST,ORDIALOG,ORSD to be defined
    67         ;
    68         Q:$G(ORCAT)="O"  Q:$G(ORTYPE)="Z"  ;skip if outpt or editor
    69         N LAST,STRT,DUR,D1,D2,OFF,F1,F2,UNT,Y1,Y2,I,J K Y
    70         S LAST=+$O(ORDIALOG(+$$PTR^ORCD("OR GTX INSTRUCTIONS"),INST),-1)
    71         S STRT=$G(ORDIALOG(PROMPT,LAST))
    72         I LAST'>0!'$L(STRT) S:$L($P($G(ORSD),U)) Y=$P(ORSD,U) Q  ;first inst
    73         S DUR=$G(ORDIALOG(+$$PTR^ORCD("OR GTX DURATION"),LAST))
    74         I +DUR'>0 S Y=STRT Q  ;no duration = same start
    75         S DUR=$$FMDUR(DUR) I STRT D  Q  ;FM date/time, so just add
    76         . N X,%DT S %DT="TX",X=STRT_"+"_DUR D ^%DT
    77         . I Y'>0 S Y=STRT ;error
    78         S D1=+DUR,D2=$P(DUR,D1,2) S:(STRT="NEXTA")!(STRT="CLOSEST") STRT="NOW"
    79         S OFF=$P(STRT,"+",2) I '$L(OFF) S Y=STRT_"+"_DUR Q  ;no prev offset
    80         S F1=+OFF,F2=$P(OFF,F1,2),UNT=F2,Y=STRT
    81         I D2=F2 S Y=$P(STRT,"+")_"+"_(D1+F1)_UNT Q  ;same units
    82         F I="S","'","H","D","W","M" I (F2=I)!(D2=I) S UNT=I D  Q
    83         . S:D2=UNT Y1=D1,X1=F1,X2=F2 ; Y1=# in UNT
    84         . S:F2=UNT Y1=F1,X1=D1,X2=D2 ; X1=# in other units X2
    85         . F J=1:1 S Z=$T(CONV+J) Q:Z["ZZZZ"  I $P(Z,";",3,4)=(X2_";"_UNT) S Y2=+$P(Z,";",5) Q
    86         . S Y=$P(STRT,"+")_"+"_(Y1+$S(Y2:Y2*X1,1:0))_UNT
    87         Q
    88         ;
    89 FMDUR(X)               ; -- convert '# DAYS' to #D
    90         N X1,X2,Y I +X'>0 Q ""
    91         S X1=+X,X2=$P(X," ",2) S:'$L(X2) X2="DAYS"
    92         S Y=X1_$S("MINUTES"[X2:"'",1:$E(X2))
    93         Q Y
    94         ;
    95 CONV    ;;unit;unit;factor
    96         ;;';S;60
    97         ;;H;';60
    98         ;;H;S;3600
    99         ;;D;H;24
    100         ;;D;';1440
    101         ;;D;S;86400
    102         ;;W;D;7
    103         ;;W;H;168
    104         ;;W;';10080
    105         ;;W;S;604800
    106         ;;M;W;4
    107         ;;M;D;30
    108         ;;M;H;720
    109         ;;M;';43200
    110         ;;M;S;2592000
    111         ;;ZZZZ
    112         ;
    113 ASKDUR()               ; -- Returns 1 or 0, if Duration prompt should be asked
    114         K ^TMP($J,"ORCDPS3 ASKDUR")
    115         N X,Y I '$G(ORCOMPLX) K ORDIALOG(PROMPT,INST) Q 0
    116         S Y=1 G:'$L($G(ORSCH)) ADQ ;no schedule
    117         D AP^PSS51P1("PSJ",,,,"ORCDPS3 ASKDUR")
    118         S X=+$O(^TMP($J,"ORCDPS3 ASKDUR","APPSJ",ORSCH,"")) G:X'>0 ADQ
    119         ;S X=+$O(^PS(51.1,"APPSJ",ORSCH,0)) G:X'>0 ADQ
    120         S:^TMP($J,"ORCDPS3 ASKDUR",X,5)="O" Y=0
    121         ;S:$P($G(^PS(51.1,X,0)),U,5)="O" Y=0
    122 ADQ     ;
    123         K ^TMP($J,"ORCDPS3 ASKDUR")
    124         Q Y
    125         ;
    126 CKDUR(X)        ; -- Returns validated form of duration X, or null if invalid
    127         N X1,X2,Y,Z S Y=""
    128         S X1=+$G(X),X2=$P($G(X),X1,2) I X1'>0 Q ""
    129         S X2=$$UP^XLFSTR(X2),X2=$$STRIP^XLFSTR(X2," ") S:'$L(X2) X2="DAYS"
    130         F Z="MONTHS^&MONTHS&MONS","WEEKS^&WEEKS&WKS","DAYS^&DAYS&DYS","HOURS^&HOURS&HRS","MINUTES^&MINUTES&MINS'","SECONDS^&SECONDS&SECS" I $P(Z,U,2)[("&"_X2) S Y=$P(Z,U) Q
    131         S:$L(Y) Y=X1_" "_$S(X1=1:$E(Y,1,$L(Y)-1),1:Y) ;strip trailing 's'
    132         Q Y
    133         ;
    134 DUR     ; -- Process duration [from P-S Action]
    135         N X S X=$G(ORDIALOG(PROMPT,ORI)),X=$$CKDUR(X)
    136         I '$L(X) K DONE W $C(7),!,ORDIALOG(PROMPT,"?"),! Q
    137         S ORDIALOG(PROMPT,ORI)=X D:$G(ORESET)'=X CHANGED^ORCDPS1("QUANTITY")
    138         Q
    139         ;
    140 TEST(START,DURTN)             ; -- test DEFSTRT
    141         N INST,ORSD,ORDIALOG,PROMPT
    142         S ORDIALOG(136,1)="",INST=2,ORSD="NOW",PROMPT=6
    143         S:$L($G(START)) ORDIALOG(6,1)=START S:$G(DURTN) ORDIALOG(153,1)=DURTN
    144         D DEFSTRT W !,Y
    145         Q
    146         ;
    147 SC      ; -- Dialog validation, to ask SC questions
    148         ;    Expects ORIFN, ORDA, and ORDER
    149         ;
    150         Q:'$L($T(SCNEW^PSOCP))  Q:'$G(ORIFN)  Q:'$G(ORDA)
    151         Q:$P($G(^OR(100,ORIFN,0)),U,12)'="O"  Q:$P($G(^(8,ORDA,0)),U,2)'="NW"  Q:$P($G(^(0)),U,15)=""
    152         ;
    153         N OR3,ORDRUG,PSIFN,ORX,I,J,DIE,DR,DA,X,Y,DTOUT,ORIGVIEW,DFN
    154         S OR3=$G(^OR(100,ORIFN,3)),X=$P(OR3,U,11) I X>2 Q  ;new, edit, or renew
    155         I X S Y=$P(OR3,U,5),PSIFN=$G(^OR(100,Y,4)) ;get PS# if edit/renewal
    156         S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
    157         D SCNEW^PSOCP(.ORX,+ORVP,ORDRUG,$G(PSIFN)) Q:'$D(ORX)
    158         S DIE="^OR(100,",DA=ORIFN,DR="",J=0
    159         F I="SC","MST","AO","IR","EC","HNC","CV" S J=J+1 I $D(ORX(I)) S X=ORX(I) S:I="CV"&(X="") X=1 S DR=DR_";5"_J_"R"_$S($L(X):"//"_$S(X:"YES",1:"NO"),1:"")
    160         S:$E(DR)=";" DR=$E(DR,2,999) Q:'$L(DR)  S ORIGVIEW=1
    161         I $D(ORX("SC")) S DFN=+ORVP D DIS^DGRPDB ;show current SC data
    162         W !!,"Is "_$$ORDITEM^ORCACT(ORDER)_" for treatment related to:"
    163         D ^DIE S:$D(DTOUT)!$D(Y) ORQUIT=1
    164         Q
     1ORCDPS3 ;SLC/MKB-Pharmacy dialog utilities ;11/25/02  09:47
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,158,149,190,277**;Dec 17, 199;Build 13
     3 ;
     4START ; -- Start Date entry action
     5 S $P(ORDIALOG(PROMPT,0),":",3)=$S($G(ORCAT)="I":"ETRX",1:"EX")
     6 I $G(ORCAT)'="I" K ORSD K:$G(ORENEW)!$G(OREWRITE)!$D(OREDIT) ORDIALOG(PROMPT,INST) ;Inpt only
     7 Q
     8 ;
     9ADMIN ; -- Return default admin time for order in ORSD
     10 ;    Called from EXDOSE^ORCDPS2
     11 Q:$D(ORSD)  Q:$G(ORCAT)'="I"  ;inpt only
     12 N PSOI,PSIFN,SCH,CNJ,ORI,ORX
     13 S PSOI=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2)
     14 S PSIFN=$S($G(ORENEW):$G(^OR(100,+$G(ORIFN),4)),1:"")
     15 S SCH=$$PTR^ORCD("OR GTX SCHEDULE"),CNJ=$$PTR^ORCD("OR GTX AND/THEN"),ORX=""
     16 S ORI=0 F  S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1  S ORX=ORX_$S($L(ORX):U,1:"")_$G(ORDIALOG(CNJ,ORI))_";"_$G(ORDIALOG(SCH,ORI))
     17 S ORSD=$$FIRST(+ORVP,+$G(ORWARD),PSOI,ORX,PSIFN)
     18 S:$P(ORSD,U)="NEXT" ORSD="NEXTA^"_$P(ORSD,U,2,99)
     19 Q
     20 ;
     21FIRST(DFN,WARD,OI,DATA,ORDER) ; -- Return expected first admin time of order
     22 N ORCNT,ORI,J,ORZ,Y,SCH,ORX I '$G(DFN)!'$G(OI) Q ""
     23 S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D  Q:$E(ORZ)="T"
     24 . S SCH=$P(ORZ,";",2) Q:'$L(SCH)  S ORCNT=ORCNT+1
     25 . S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER))
     26 S Y=9999999,J=0
     27 F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ<Y S Y=ORZ,J=ORI ;earliest
     28 S Y=$S(J:ORX(J),1:"")
     29 Q Y
     30 ;
     31NOW ; -- First dose now?
     32 N X,Y,DIR,SCH
     33 I $G(ORCAT)="O"!'$D(ORSD)!$L($G(OREVENT))!$G(ORENEW) K ORDIALOG(PROMPT,INST) Q
     34 ; ask on Copy? Change?
     35 S X=$$PTR^ORCD("OR GTX SCHEDULE"),Y=+$O(ORDIALOG(X,0))
     36 S SCH=$G(ORDIALOG(X,Y)),Y=+$O(^PS(51.1,"APPSJ",SCH,0)) ;1st one
     37 I $P($G(^PS(51.1,Y,0)),U,5)="O"!(Y<1) K ORDIALOG(PROMPT,INST) Q
     38 ; other conditions?
     39 S DIR(0)="YA",DIR("A")="Give additional dose NOW? "
     40 S DIR("B")=$S($G(ORDIALOG(PROMPT,INST)):"YES",1:"NO")
     41 I ORINPT,$P(ORSD,U,4) S DIR("A",1)="Next scheduled administration time: "_$$FMTE^XLFDT($P(ORSD,U,4))
     42 S DIR("?")="Enter YES if you want a dose given now in addition to the regular administration times for this schedule and ward."
     43 D ^DIR S:$D(DTOUT)!$D(DUOUT) ORQUIT=1
     44 I $G(ORQUIT)!(Y'>0) K ORDIALOG(PROMPT,INST) Q
     45 S ORDIALOG(PROMPT,INST)=1 I $G(ORCOMPLX) D
     46 . W $C(7),!,"  >> First Dose NOW is in addition to those already entered.    <<"
     47 . W !,"  >> Please adjust the duration of the first one, if necessary. <<"
     48 Q
     49 ;
     50DEFSTRT ; -- Returns default start date/time in Y
     51 ;    Expects PROMPT,INST,ORDIALOG,ORSD to be defined
     52 ;
     53 Q:$G(ORCAT)="O"  Q:$G(ORTYPE)="Z"  ;skip if outpt or editor
     54 N LAST,STRT,DUR,D1,D2,OFF,F1,F2,UNT,Y1,Y2,I,J K Y
     55 S LAST=+$O(ORDIALOG(+$$PTR^ORCD("OR GTX INSTRUCTIONS"),INST),-1)
     56 S STRT=$G(ORDIALOG(PROMPT,LAST))
     57 I LAST'>0!'$L(STRT) S:$L($P($G(ORSD),U)) Y=$P(ORSD,U) Q  ;first inst
     58 S DUR=$G(ORDIALOG(+$$PTR^ORCD("OR GTX DURATION"),LAST))
     59 I +DUR'>0 S Y=STRT Q  ;no duration = same start
     60 S DUR=$$FMDUR(DUR) I STRT D  Q  ;FM date/time, so just add
     61 . N X,%DT S %DT="TX",X=STRT_"+"_DUR D ^%DT
     62 . I Y'>0 S Y=STRT ;error
     63 S D1=+DUR,D2=$P(DUR,D1,2) S:(STRT="NEXTA")!(STRT="CLOSEST") STRT="NOW"
     64 S OFF=$P(STRT,"+",2) I '$L(OFF) S Y=STRT_"+"_DUR Q  ;no prev offset
     65 S F1=+OFF,F2=$P(OFF,F1,2),UNT=F2,Y=STRT
     66 I D2=F2 S Y=$P(STRT,"+")_"+"_(D1+F1)_UNT Q  ;same units
     67 F I="S","'","H","D","W","M" I (F2=I)!(D2=I) S UNT=I D  Q
     68 . S:D2=UNT Y1=D1,X1=F1,X2=F2 ; Y1=# in UNT
     69 . S:F2=UNT Y1=F1,X1=D1,X2=D2 ; X1=# in other units X2
     70 . F J=1:1 S Z=$T(CONV+J) Q:Z["ZZZZ"  I $P(Z,";",3,4)=(X2_";"_UNT) S Y2=+$P(Z,";",5) Q
     71 . S Y=$P(STRT,"+")_"+"_(Y1+$S(Y2:Y2*X1,1:0))_UNT
     72 Q
     73 ;
     74FMDUR(X) ; -- convert '# DAYS' to #D
     75 N X1,X2,Y I +X'>0 Q ""
     76 S X1=+X,X2=$P(X," ",2) S:'$L(X2) X2="DAYS"
     77 S Y=X1_$S("MINUTES"[X2:"'",1:$E(X2))
     78 Q Y
     79 ;
     80CONV ;;unit;unit;factor
     81 ;;';S;60
     82 ;;H;';60
     83 ;;H;S;3600
     84 ;;D;H;24
     85 ;;D;';1440
     86 ;;D;S;86400
     87 ;;W;D;7
     88 ;;W;H;168
     89 ;;W;';10080
     90 ;;W;S;604800
     91 ;;M;W;4
     92 ;;M;D;30
     93 ;;M;H;720
     94 ;;M;';43200
     95 ;;M;S;2592000
     96 ;;ZZZZ
     97 ;
     98ASKDUR() ; -- Returns 1 or 0, if Duration prompt should be asked
     99 N X,Y I '$G(ORCOMPLX) K ORDIALOG(PROMPT,INST) Q 0
     100 S Y=1 G:'$L($G(ORSCH)) ADQ ;no schedule
     101 S X=+$O(^PS(51.1,"APPSJ",ORSCH,0)) G:X'>0 ADQ
     102 S:$P($G(^PS(51.1,X,0)),U,5)="O" Y=0
     103ADQ Q Y
     104 ;
     105CKDUR(X) ; -- Returns validated form of duration X, or null if invalid
     106 N X1,X2,Y,Z S Y=""
     107 S X1=+$G(X),X2=$P($G(X),X1,2) I X1'>0 Q ""
     108 S X2=$$UP^XLFSTR(X2),X2=$$STRIP^XLFSTR(X2," ") S:'$L(X2) X2="DAYS"
     109 F Z="MONTHS^&MONTHS&MONS","WEEKS^&WEEKS&WKS","DAYS^&DAYS&DYS","HOURS^&HOURS&HRS","MINUTES^&MINUTES&MINS'","SECONDS^&SECONDS&SECS" I $P(Z,U,2)[("&"_X2) S Y=$P(Z,U) Q
     110 S:$L(Y) Y=X1_" "_$S(X1=1:$E(Y,1,$L(Y)-1),1:Y) ;strip trailing 's'
     111 Q Y
     112 ;
     113DUR ; -- Process duration [from P-S Action]
     114 N X S X=$G(ORDIALOG(PROMPT,ORI)),X=$$CKDUR(X)
     115 I '$L(X) K DONE W $C(7),!,ORDIALOG(PROMPT,"?"),! Q
     116 S ORDIALOG(PROMPT,ORI)=X D:$G(ORESET)'=X CHANGED^ORCDPS1("QUANTITY")
     117 Q
     118 ;
     119TEST(START,DURTN) ; -- test DEFSTRT
     120 N INST,ORSD,ORDIALOG,PROMPT
     121 S ORDIALOG(136,1)="",INST=2,ORSD="NOW",PROMPT=6
     122 S:$L($G(START)) ORDIALOG(6,1)=START S:$G(DURTN) ORDIALOG(153,1)=DURTN
     123 D DEFSTRT W !,Y
     124 Q
     125 ;
     126SC ; -- Dialog validation, to ask SC questions
     127 ;    Expects ORIFN, ORDA, and ORDER
     128 ;
     129 Q:'$L($T(SCNEW^PSOCP))  Q:'$G(ORIFN)  Q:'$G(ORDA)
     130 Q:$P($G(^OR(100,ORIFN,0)),U,12)'="O"  Q:$P($G(^(8,ORDA,0)),U,2)'="NW"  Q:$P($G(^(0)),U,15)=""
     131 ;
     132 N OR3,ORDRUG,PSIFN,ORX,I,J,DIE,DR,DA,X,Y,DTOUT,ORIGVIEW,DFN
     133 S OR3=$G(^OR(100,ORIFN,3)),X=$P(OR3,U,11) I X>2 Q  ;new, edit, or renew
     134 I X S Y=$P(OR3,U,5),PSIFN=$G(^OR(100,Y,4)) ;get PS# if edit/renewal
     135 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
     136 D SCNEW^PSOCP(.ORX,+ORVP,ORDRUG,$G(PSIFN)) Q:'$D(ORX)
     137 S DIE="^OR(100,",DA=ORIFN,DR="",J=0
     138 F I="SC","MST","AO","IR","EC","HNC","CV" S J=J+1 I $D(ORX(I)) S X=ORX(I) S:I="CV"&(X="") X=1 S DR=DR_";5"_J_"R"_$S($L(X):"//"_$S(X:"YES",1:"NO"),1:"")
     139 S:$E(DR)=";" DR=$E(DR,2,999) Q:'$L(DR)  S ORIGVIEW=1
     140 I $D(ORX("SC")) S DFN=+ORVP D DIS^DGRPDB ;show current SC data
     141 W !!,"Is "_$$ORDITEM^ORCACT(ORDER)_" for treatment related to:"
     142 D ^DIE S:$D(DTOUT)!$D(Y) ORQUIT=1
     143 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSH.m

    r613 r623  
    1 ORCDPSH ;SLC/CLA-Pharmacy dialog utilities-Non-VA Meds ; 09 April 2003 11:00 AM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 2418   START^PSSJORDF   ^TMP("PSJMR",$J)
    5         ; DBIA 3166   EN^PSSDIN        ^TMP("PSSDIN",$J)
    6         ;
    7 EN(TYPE)        ; -- entry action for Meds dialogs
    8         S ORDG=+$O(^ORD(100.98,"B","NV RX",0)),ORCAT="O"
    9         K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    10         I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D
    11         . K ORDIALOG($$PTR("START DATE/TIME"),1)
    12         . K ORDIALOG($$PTR("NOW"),1)
    13         . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J)
    14         Q
    15         ;
    16 EN1     ; -- setup Non-VA Meds dialog for quick order editor using ORDG
    17         N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
    18         S ORINPT=0,ORCAT="O"
    19         K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    20         Q
    21         ;
    22 ENOI    ; -- setup OI prompt
    23         S ORDIALOG(PROMPT,"D")="S.NV RX"
    24         Q
    25         ;
    26 CHANGED(X)      ; -- Kill dependent values when prompt X changes
    27         N PROMPTS,NAME,PTR,P,I
    28         S PROMPTS=X I X="OI" D
    29         . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS"
    30         . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY
    31         . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    32         F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
    33         . S PTR=$$PTR(NAME) Q:'PTR
    34         . S I=0 F  S I=$O(ORDIALOG(PTR,I)) Q:I'>0  K ORDIALOG(PTR,I)
    35         . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR)
    36         Q
    37         ;
    38 ORDITM(OI)      ; -- Check OI inactive date & type, get dependent info
    39         Q:OI'>0  ;quit - no value
    40         N ORPS,PSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),PSOI=+$P($G(^(0)),U,2)
    41         S ORIV=$S($P(ORPS,U)=2:1,1:0)
    42         I '$P(ORPS,U,7) W $C(7),!,"This drug may not be used in a non-VA med order." S ORQUIT=1 D WAIT Q
    43 OI1     ; ck NF status (don't care if Non-VA Meds are formulary or not)
    44 OI2     ; -get selectable routes, doses [also called from NF^ORCDPS]
    45         D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(PSOI,$G(ORCAT))  ;DBIA 2418
    46         I '$D(ORDOSE) D
    47         . D DOSE^PSSORUTL(.ORDOSE,PSOI,"X",+ORVP)
    48         . K:$G(ORDOSE(1))=-1 ORDOSE
    49         Q
    50         ;
    51 NFI(OI) ; -- Show NFI restrictions, if exist
    52         N PSOI,I,J,LCNT,MAX,X,STOP
    53         S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2)
    54         D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI))  ;DBIA 3166
    55         S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W !
    56         F  S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0  D
    57         . S J=0 F  S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0  S X=$G(^(J)) D  Q:$G(STOP)
    58         .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP)  S LCNT=1
    59         .. W !,X
    60         W ! K ^TMP("PSSDIN",$J,"OI",PSOI)
    61         Q
    62         ;
    63 CONT()  ; -- Press return to cont or ^ to stop
    64         N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA"
    65         S DIR("A")="Press <return> to continue or ^ to stop ..."
    66         D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
    67         Q +Y
    68         ;
    69 WAIT    ; -- Wait for user
    70         N X W !,"Press <return> to continue ..." R X:DTIME
    71         Q
    72         ;
    73 ROUTES  ; -- Get allowable med routes
    74         Q:$G(ORDIALOG(PROMPT,"LIST"))  N I,X,CNT S (I,CNT)=0
    75         F  S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0  S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3)
    76         S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT
    77         S REQD=0
    78         Q
    79         ;
    80 DEFRTE  ; -- Get default route
    81         N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST ;1st inst
    82         I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q
    83         S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1
    84         Q
    85         ;
    86 CKSCH   ; -- validate schedule [Called from P-S Action]
    87         N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET)  K ORSD ;reset
    88         D EN^PSSGS0(.ORX,"X")
    89         I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q  ;ok
    90         W $C(7),!,"Enter a standard schedule for administering this medication or one of your own,",!,"up to 20 characters.",!
    91         K DONE
    92         Q
    93         ;
    94 PTR(X)  ; -- Return ptr to prompt OR GTX X
    95         Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
    96         ;
    97 EXIT    ; -- exit action for Meds dialogs
    98         S:$G(ORXNP) ORNP=ORXNP
    99         K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX
    100         K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    101         Q
     1ORCDPSH ;SLC/CLA-Pharmacy dialog utilities-Non-VA Meds ; 09 April 2003 11:00 AM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,215**;Dec 17, 1997
     3 ;
     4 ; DBIA 2418   START^PSSJORDF   ^TMP("PSJMR",$J)
     5 ; DBIA 3166   EN^PSSDIN        ^TMP("PSSDIN",$J)
     6 ;
     7EN(TYPE) ; -- entry action for Meds dialogs
     8 S ORDG=+$O(^ORD(100.98,"B","NV RX",0)),ORCAT="O"
     9 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     10 I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D
     11 . K ORDIALOG($$PTR("START DATE/TIME"),1)
     12 . K ORDIALOG($$PTR("NOW"),1)
     13 . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J)
     14 Q
     15 ;
     16EN1 ; -- setup Non-VA Meds dialog for quick order editor using ORDG
     17 N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
     18 S ORINPT=0,ORCAT="O"
     19 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     20 Q
     21 ;
     22ENOI ; -- setup OI prompt
     23 S ORDIALOG(PROMPT,"D")="S.NV RX"
     24 Q
     25 ;
     26CHANGED(X) ; -- Kill dependent values when prompt X changes
     27 N PROMPTS,NAME,PTR,P,I
     28 S PROMPTS=X I X="OI" D
     29 . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS"
     30 . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY
     31 . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     32 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
     33 . S PTR=$$PTR(NAME) Q:'PTR
     34 . S I=0 F  S I=$O(ORDIALOG(PTR,I)) Q:I'>0  K ORDIALOG(PTR,I)
     35 . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR)
     36 Q
     37 ;
     38ORDITM(OI) ; -- Check OI inactive date & type, get dependent info
     39 Q:OI'>0  ;quit - no value
     40 N ORPS,PSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),PSOI=+$P($G(^(0)),U,2)
     41 S ORIV=$S($P(ORPS,U)=2:1,1:0)
     42 I '$P(ORPS,U,7) W $C(7),!,"This drug may not be used in a non-VA med order." S ORQUIT=1 D WAIT Q
     43OI1 ; ck NF status (don't care if Non-VA Meds are formulary or not)
     44OI2 ; -get selectable routes, doses [also called from NF^ORCDPS]
     45 D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(PSOI,$G(ORCAT))  ;DBIA 2418
     46 I '$D(ORDOSE) D
     47 . D DOSE^PSSORUTL(.ORDOSE,PSOI,"X",+ORVP)
     48 . K:$G(ORDOSE(1))=-1 ORDOSE
     49 Q
     50 ;
     51NFI(OI) ; -- Show NFI restrictions, if exist
     52 N PSOI,I,J,LCNT,MAX,X,STOP
     53 S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2)
     54 D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI))  ;DBIA 3166
     55 S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W !
     56 F  S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0  D
     57 . S J=0 F  S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0  S X=$G(^(J)) D  Q:$G(STOP)
     58 .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP)  S LCNT=1
     59 .. W !,X
     60 W ! K ^TMP("PSSDIN",$J,"OI",PSOI)
     61 Q
     62 ;
     63CONT() ; -- Press return to cont or ^ to stop
     64 N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA"
     65 S DIR("A")="Press <return> to continue or ^ to stop ..."
     66 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
     67 Q +Y
     68 ;
     69WAIT ; -- Wait for user
     70 N X W !,"Press <return> to continue ..." R X:DTIME
     71 Q
     72 ;
     73ROUTES ; -- Get allowable med routes
     74 Q:$G(ORDIALOG(PROMPT,"LIST"))  N I,X,CNT S (I,CNT)=0
     75 F  S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0  S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3)
     76 S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT
     77 S REQD=0
     78 Q
     79 ;
     80DEFRTE ; -- Get default route
     81 N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST ;1st inst
     82 I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q
     83 S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1
     84 Q
     85 ;
     86CKSCH ; -- validate schedule [Called from P-S Action]
     87 N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET)  K ORSD ;reset
     88 D EN^PSSGS0(.ORX,"X")
     89 I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q  ;ok
     90 W $C(7),!,"Enter either a standard administration schedule or one of your own,",!,"up to 70 characters and no more than 2 spaces.",!
     91 K DONE
     92 Q
     93 ;
     94PTR(X) ; -- Return ptr to prompt OR GTX X
     95 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
     96 ;
     97EXIT ; -- exit action for Meds dialogs
     98 S:$G(ORXNP) ORNP=ORXNP
     99 K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX
     100 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     101 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSIV.m

    r613 r623  
    1 ORCDPSIV        ;SLC/MKB-Pharmacy IV dialog utilities ;5/07/08
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195,243**;Dec 17, 1997;Build 242
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 CKSCH   ; -- validate schedule [Called from P-S Action]
    5         N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET)  K ORSD
    6         D EN^PSSGS0(.ORX,"I")
    7         I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX Q
    8         W $C(7),!,"Enter a standard schedule for administering this medication."
    9         Q
    10 ISONETIM(SCH)   ;
    11         N DUR
    12         I SCH="" Q 0
    13         K ^TMP($J,"ORCDPSIV GETSCHTYP")
    14         D ZERO^PSS51P1(,SCH,"PSJ","O","ORCDPSIV GETSCHTYP")
    15         I +^TMP($J,"ORCDPSIV GETSCHTYP",0)>0 D  Q 1
    16         .S DUR=$$PTR^ORCD("OR GTX DURATION")
    17         .I $G(ORDIALOG(DUR,1))="" Q
    18         .S ORDIALOG(DUR,1)=""
    19         .W !,"IV Orders with a schedule type of one-time cannot have a duration."
    20         .W !,"The duration has been deleted from this quick order." H 1
    21         K ^TMP($J,"ORCDPSIV GETSCHTYP")
    22         Q 0
    23         ;
    24 PROVIDER        ; -- Check provider, if authorized to write med orders
    25         I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q
    26         N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2)
    27         I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U)
    28         I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1
    29         I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1
    30         I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT
    31         Q
    32         ;
    33 MEDPROV()       ; -- Return ordering med provider
    34         N X,Y,D,DIC
    35         S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER"
    36         S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)"
    37         D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^"
    38         Q Y
    39         ;
    40 CHANGED(TYPE)   ; -- Kill dependent values when OI changes
    41         N PROMPTS,NAME,PTR,P,I
    42         Q:'$L($G(TYPE))  S PROMPTS=""
    43         S:TYPE="B" PROMPTS="VOLUME"
    44         S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS"
    45         S:TYPE="T" PROMPTS="INFUSION RATE^SCHEDULE"
    46         F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
    47         . S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR
    48         . S I=0 F  S I=$O(ORDIALOG(PTR,I)) Q:I'>0  K ORDIALOG(PTR,I)
    49         . K ORDIALOG(PTR,"LIST")
    50         Q
    51         ;
    52 INACTIVE(TYPE)  ; -- Check OI inactive date
    53         N OI,X,I,PSOI,DEA,EXIT S:$G(TYPE)'="A" TYPE="S"
    54         S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0
    55         I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D  Q  ;inactive
    56         . S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1
    57         . W $C(7),!,"This "_X_" may not be ordered anymore.  Please select another."
    58         S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D  Q
    59         . S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1
    60         . W $C(7),!,"This item may not be ordered as "_X_"."
    61         S EXIT=$$INPT^ORCD I EXIT=0 D ROUTECHK Q
    62         Q:'$L($T(IVDEA^PSSUTIL1))  ;DBIA #3784
    63         S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
    64         S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D  Q:$G(ORQUIT)
    65         . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q
    66         . I DEA=1 W $C(7),!,"This order will require a wet signature!"
    67         D ROUTECHK
    68         Q
    69         ;
    70 VOLUME  ; -- get allowable volumes for solution
    71         N PSOI,ORY,CNT,I,XORY K ORDIALOG(PROMPT,"LIST")
    72         S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B"
    73         D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY
    74         ;S (I,CNT)=0 F  S I=$O(ORY(I)) Q:I'>0  S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I)
    75         S (I,CNT)=0 F  S I=$O(ORY(I)) Q:I'>0  D
    76         . S CNT=CNT+1
    77         . S XORY(I)=+ORY(I) I XORY(I)<1,$E(XORY(I),1,2)'="0." S XORY(I)=0_XORY(I)
    78         . S ORDIALOG(PROMPT,"LIST",XORY(I))=XORY(I)
    79         S ORDIALOG(PROMPT,"LIST")=CNT_"^1"
    80         Q
    81         ;
    82 UNITS   ; -- get allowable units for current additive
    83         N PSOI,ORY,I,UNITS
    84         S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A"
    85         D ENVOL^PSJORUT2(PSOI,.ORY)
    86         S I=$O(ORY(0)) Q:'I  S UNITS=$P($G(ORY(I)),U,2)
    87         S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS
    88         W !," (Units for this additive are "_UNITS_")"
    89         Q
    90         ;
    91 PREMIX()        ; -- Returns 1 or 0, if IV base is a premix solution
    92         N BASE,PS,I,Y
    93         S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0
    94         S I=0 F  S I=$O(ORDIALOG(BASE,I)) Q:I'>0  D  Q:Y
    95         . S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS"))
    96         . I $P(PS,U,3)&($P(PS,U,4)) S Y=1
    97         Q Y
    98         ;
    99 IVRTEENT        ;
    100         N ARRAY,DIR,RIEN,TROUTE
    101         I ORTYPE'="Z" Q
    102         S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0
    103         S EXIT=0,TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0
    104         I $$IVRTESCR(TROUTE)=1 Q
    105         S ORDIALOG(RIEN,1)=""
    106         W !!,"The selected route is not a valid route for this order."
    107         W !,"Select a new route for this order from the list of routes below."
    108         D RTEDISP(.ARRAY)
    109         Q
    110         ;
    111 BIVOI(ARRAY)    ;
    112         N CNT,NUM,OIIEN,OTYPE
    113         S CNT=0
    114         F OTYPE="SOLUTION","ADDITIVE" D
    115         .S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D
    116         ..S NUM=0 F  S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0  I +$G(ORDIALOG(OIIEN,NUM))>0 D
    117         ...S CNT=CNT+1,ARRAY(CNT)=ORDIALOG(OIIEN,NUM)
    118         Q
    119         ;
    120 LVROUTES        ;
    121         N ARRAY,ROUTES
    122         D BIVOI(.ARRAY)
    123         D IVDOSFRM^ORWDPS33(.ROUTES,.ARRAY,0,1)
    124         D RTEDISP(.ROUTES)
    125         Q
    126         ;
    127 RTEDISP(ROUTES) ;
    128         N CNT
    129         S CNT="" F  S CNT=$O(ROUTES(CNT)) Q:CNT'>0  D
    130         .W !,$P($G(ROUTES(CNT)),U,2)
    131         Q
    132         ;
    133 IVRTESCR(Y)     ;
    134         N ARRAY,ROUTES,VALUE
    135         D BIVOI(.ARRAY)
    136         S VALUE=$$IVQOVAL^ORWDPS33(.ARRAY,Y) I VALUE'="" Q 1
    137         Q 0
    138         ;
    139 ROUTECHK        ;
    140         N CNT,IEN,ROUTE,VALUE
    141         S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0
    142         S TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0
    143         I $$IVRTESCR(TROUTE)=1 Q
    144         S ORDIALOG(RIEN,1)=""
    145         W !!,"The route defined for this order is an invalid route."
    146         W !,"You will need to define a new route for this order."
    147         Q
    148         ;
    149 ENRATE  ; -- set display text, help based on IV TYPE
    150         N X,MSG S X=$G(ORIVTYPE),MSG=""
    151         S ORDIALOG(PROMPT,"A")=$S(X="I":"Infuse over time (min): ",1:"Infusion Rate (ml/hr): ")
    152         S MSG="Enter the "_$S(X="I":"number of minutes over which to infuse this medication.",1:"infusion rate, as the number of ml/hr or Text@Number of Labels per day. ")
    153         S ORDIALOG(PROMPT,"?")=MSG
    154         I X="I" D
    155         .N RATEI,RATEV,TIME,UNIT
    156         .S RATEI=$P($G(ORDIALOG("B","INFUSION RATE")),U,2) Q:RATEI'>0
    157         .S RATEV=$G(ORDIALOG(RATEI,1)) Q:'$L(RATEV)
    158         .I RATEV'["INFUSE OVER" Q
    159         .S TIME=$P(RATEV," ",3)
    160         .S UNIT=$P(RATEV," ",4)
    161         .I TIME["." Q
    162         .I UNIT="Hours" S TIME=TIME*60
    163         .S ORDIALOG(RATEI,1)=TIME
    164         Q
    165         ;
    166 INF     ; -- input transform for INFUSION RATE
    167         N ALPHA,CNT,EXIT,FAIL,LDEC,RDEC,TEMP
    168         I $G(ORIVTYPE)="I" D  Q
    169         .I X["." W !,"Infuse Over Time must be a whole number." K X Q
    170         .I $L(X)>4 W !,"Infuse Over Time cannot exceed 4 spaces for minutes." K X
    171         .S FAIL=0
    172         .F CNT=1:1:$L(X) D  I FAIL=1 Q
    173         ..I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S FAIL=1
    174         .I FAIL=1 W !,"Infuse Over Time must be a whole number." K X Q
    175         K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
    176         I $G(ORIVTYPE)="C" D  Q
    177         .S TEMP=$E(X,($L(X)-5),$L(X))
    178         .I X["@",$$UP^XLFSTR(TEMP)=" ML/HR" Q
    179         .S ALPHA=0
    180         .I X'["@" D  I ALPHA=1 K X Q
    181         ..F CNT=1:1:$L(X) D  I ALPHA=1 Q
    182         ...I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S ALPHA=1
    183         .S EXIT=0
    184         .I X[".",X'["@" D  I EXIT=1 K X Q
    185         ..S LDEC=$P(X,"."),RDEC=$P(X,".",2)
    186         ..I LDEC="" W !,"Infusion Rate required a leading numeric value." S EXIT=1
    187         ..I $L(RDEC)>1 W !,"Infusion Rate cannot exceed one decimal place." S EXIT=1
    188         ..S ALPHA=0
    189         ..F CNT=1:1:$L(LDEC) D  I ALPHA=1 S EXIT=1 Q
    190         ...I ($A($E(LDEC,CNT))<48)!($A($E(LDEC,CNT))>58) S ALPHA=1
    191         ..I $L(RDEC)=0 Q
    192         ..F CNT=1:1:$L(RDEC) D  I ALPHA=1 S EXIT=1 Q
    193         ...I ($A($E(RDEC,CNT))<48)!($A($E(RDEC,CNT))>58) S ALPHA=1
    194         .D ORINF^PSIVSP Q
    195         ; -- assume #minutes for now
    196         K:(X'=+X)!(X<1)!(X>999) X ;range?
    197         Q
    198         ;
    199 VALIDAYS(X)     ; -- Validate IV duration
    200         N UNITS,X1,X2,Y,I
    201         I X'?1.N." "1.A Q 0
    202         S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)=""
    203         F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y)
    204         I 'X1 Q 0
    205         I UNITS'[(U_X2_U) Q 0
    206         Q 1
    207         ;
    208 VALDURA(X)      ;-- Validate IV duration/limitation
    209         K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
    210         ;
    211 IVPSI   ;INPUT-TRANSFORM
    212         I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q
    213         I $L(X)>1,X[" " W !,"Spaces are not allow in the duration." K X Q
    214         I $E(X)=0 W !,!,"Duration cannot start with a zero." K X Q
    215         I X["." W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!" S X="" Q
    216         S X=$$UP^XLFSTR(X)
    217         I X["DOSES" D  Q
    218         .I $G(ORIVTYPE)'="I" K X W !,"Continuous IV Orders cannot have DOSES as a duration." Q
    219         .I +$P(X,"DOSES")<1,+$P(X,"DOSES")>200000 W !,"Invalid number of Doses.",! K X Q
    220         I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q
    221         I (X?.N1A) D
    222         . I (X["L")!(X["H")!(X["D") Q
    223         . E  W !,!,"Invalid duration or total volume.",! S X="" Q
    224         I (X?.N1".".N1A) D
    225         . I X["L" Q
    226         . E  W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q
    227         I (X?.N2A)!(X?.N1".".N2A) D
    228         . I (X["ML")!(X["CC") Q
    229         . E  W !,!,"Invalid duration or total volume",! S X="" Q
    230         I X="" K X
    231         Q
    232         ;
    233 IVPSI1  ; ASK ON CONDITION
    234         N DURI,DURV
    235         I $G(OROTSCH)=1 Q
    236         S DURI=$P($G(ORDIALOG("B","LIMITATION")),U,2)
    237         I DURI>0 S DURV=$G(ORDIALOG(DURI,1))
    238         I $L(DURV)>1,$E(DURV)="f",DURV["doses" D
    239         .S TEMPX=$P(DURV," ",5)_"DOSES"
    240         .I TEMPX'="",TEMPX'=DURV S ORDIALOG(DURI,1)=TEMPX
    241         N INT,IVTYPE,ONETIME,TYPE,SCH,SCHNAME
    242         I $G(ORIVTYPE)'="I" D  G IVPS1X
    243         .W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation."
    244         .W !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",!
    245         W !,"This field is optional a value does not need to be entered."
    246         W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation."
    247         W !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",!
    248 IVPS1X  ;
    249         W !,"This field is optional a value does not need to be entered."
    250         I 1
    251         Q
     1ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;11/25/02  09:47
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195**;Dec 17, 1997
     3PROVIDER ; -- Check provider, if authorized to write med orders
     4 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q
     5 N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2)
     6 I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U)
     7 I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1
     8 I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1
     9 I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT
     10 Q
     11 ;
     12MEDPROV() ; -- Return ordering med provider
     13 N X,Y,D,DIC
     14 S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER"
     15 S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)"
     16 D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^"
     17 Q Y
     18 ;
     19CHANGED(TYPE) ; -- Kill dependent values when OI changes
     20 N PROMPTS,NAME,PTR,P,I
     21 Q:'$L($G(TYPE))  S PROMPTS=""
     22 S:TYPE="B" PROMPTS="VOLUME"
     23 S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS"
     24 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
     25 . S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR
     26 . S I=0 F  S I=$O(ORDIALOG(PTR,I)) Q:I'>0  K ORDIALOG(PTR,I)
     27 . K ORDIALOG(PTR,"LIST")
     28 Q
     29 ;
     30INACTIVE(TYPE) ; -- Check OI inactive date
     31 N OI,X,I,PSOI,DEA S:$G(TYPE)'="A" TYPE="S"
     32 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0
     33 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D  Q  ;inactive
     34 . S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1
     35 . W $C(7),!,"This "_X_" may not be ordered anymore.  Please select another."
     36 S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D  Q
     37 . S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1
     38 . W $C(7),!,"This item may not be ordered as "_X_"."
     39 Q:'$$INPT^ORCD  Q:'$L($T(IVDEA^PSSUTIL1))  ;DBIA #3784
     40 S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
     41 S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D  Q:$G(ORQUIT)
     42 . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q
     43 . I DEA=1 W $C(7),!,"This order will require a wet signature!"
     44 Q
     45 ;
     46VOLUME ; -- get allowable volumes for solution
     47 N PSOI,ORY,CNT,I K ORDIALOG(PROMPT,"LIST")
     48 S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B"
     49 D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY
     50 S (I,CNT)=0 F  S I=$O(ORY(I)) Q:I'>0  S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I)
     51 S ORDIALOG(PROMPT,"LIST")=CNT_"^1"
     52 Q
     53 ;
     54UNITS ; -- get allowable units for current additive
     55 N PSOI,ORY,I,UNITS
     56 S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A"
     57 D ENVOL^PSJORUT2(PSOI,.ORY)
     58 S I=$O(ORY(0)) Q:'I  S UNITS=$P($G(ORY(I)),U,2)
     59 S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS
     60 W !," (Units for this additive are "_UNITS_")"
     61 Q
     62 ;
     63PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution
     64 N BASE,PS,I,Y
     65 S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0
     66 S I=0 F  S I=$O(ORDIALOG(BASE,I)) Q:I'>0  D  Q:Y
     67 . S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS"))
     68 . I $P(PS,U,3)&($P(PS,U,4)) S Y=1
     69 Q Y
     70 ;
     71VALIDAYS(X) ; -- Validate IV duration
     72 N UNITS,X1,X2,Y,I
     73 I X'?1.N." "1.A Q 0 ; invalid format
     74 S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)=""
     75 F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y)
     76 I 'X1 Q 0
     77 I UNITS'[(U_X2_U) Q 0
     78 Q 1
     79 ;
     80VALDURA(X) ;-- Validate IV duration/limitation
     81 K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
     82 ;
     83IVPSI ;INPUT-TRANSFORM
     84 I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q
     85 S X=$$UP^XLFSTR(X)
     86 I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q
     87 I (X?.N1A) D
     88 . I (X["L")!(X["H")!(X["D") Q
     89 . E  W !,!,"Invalid duration or total volume.",! S X="" Q
     90 I (X?.N1".".N1A) D
     91 . I X["L" Q
     92 . E  W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q
     93 I (X?.N2A)!(X?.N1".".N2A) D
     94 . I (X["ML")!(X["CC") Q
     95 . E  W !,!,"Invalid duration or total volume",! S X="" Q
     96 I X="" K X
     97 Q
     98 ;
     99IVPSI1 ; ASK ON CONDITION
     100 W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation."
     101 W !,"(Examples: 1500ML, 1000CC, 1.5L, 3D, or 72H)",!
     102 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCFLAG.m

    r613 r623  
    1 ORCFLAG ; SLC/MKB - Flag orders ;12/26/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN1(ORIFN)      ; -- standalone entry point to un/flag order ORIFN
    5         N ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS
    6         Q:'$G(ORIFN)  S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";1"
    7         S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2),DFN=+ORVP I 'ORVP!'$D(^(8,+$P(ORIFN,";",2),0)) W !,"Missing or invalid order!" H 1 Q
    8         D DEM^VADPT S ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2),ORAGE=VADM(4)
    9         S ORACTN=$S($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),3)):"UF",1:"FL")
    10         I '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR) W !,ORERR H 1 Q
    11         S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q
    12         S ORACTN=$S(ORACTN="UF":"UN",1:"EN"),ORPS=1
    13         D @ORACTN,UNLK1^ORX2(+ORIFN)
    14         Q
    15         ;
    16 EN      ; -- Flag order ORIFN
    17         N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12)
    18         S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to flag!" H 1 Q
    19         S OREASON=$$REASON Q:OREASON="^"
    20         S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3),ORNP=$$PROV(ORNP) Q:ORNP="^"
    21         D BULLETIN ;use ORNP?
    22         K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP
    23         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity
    24         S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
    25         W !?10,"... order flagged." H 1 D KILL^XM,MSG(ORIFN)
    26         Q
    27         ;
    28 UN      ; -- Unflag order ORIFN
    29         N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12)
    30         S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to unflag order!" H 1 Q
    31         D SHOWFLAG S OREASON=$$COMMENT Q:OREASON="^"
    32         S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON
    33         S ORNP=+$P(^OR(100,+ORIFN,8,DA,3),U,9) S:'ORNP ORNP=+$P($G(^(0)),U,3)
    34         S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
    35         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity
    36         W !?10,"... order unflagged." H 1 D MSG(ORIFN)
    37         Q
    38         ;
    39 SHOWFLAG        ; -- Display [last] flag for order ORIFN
    40         N FLAG
    41         S FLAG=$G(^OR(100,+ORIFN,8,DA,3))
    42         W !," FLAGGED: "_$$LTIM($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
    43         W !?10,$P(FLAG,U,5) ; reason
    44         Q
    45         ;
    46 REASON()        ; -- Reason for flag
    47         N X,Y,DIR
    48         S DIR(0)="FA^1:80",DIR("A")="REASON FOR FLAG: " ; ck E3R
    49         S DIR("?")="A reason must be entered to flag this order."
    50         D ^DIR
    51         Q Y
    52         ;
    53 COMMENT()       ; -- Comments on unflag
    54         N X,Y,DIR
    55         S DIR(0)="FAO^1:80",DIR("A")="COMMENTS: "
    56         S DIR("?")="A comment may be entered to clarify this order."
    57         D ^DIR S:$D(DTOUT) Y="^"
    58         Q Y
    59         ;
    60 PROV(ORDR)      ; -- Get provider to alert
    61         N X,Y,DIC
    62         S DIC=200,DIC(0)="AEQM",DIC("A")="Send alert to: "
    63         I $G(ORDR) S ORDR=$P($G(^VA(200,+ORDR,0)),U) S:$L(ORDR) DIC("B")=ORDR
    64         S DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)"
    65         D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^"
    66         Q Y
    67         ;
    68 BULLETIN        ; -- Send bulletin re: flag
    69         N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
    70         S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) ;ORUSR=+$P(OR0,U,4)
    71         S ORUSR=+$G(ORNP),ORSRV=+$P($G(^VA(200,ORUSR,5)),U)
    72         S ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG"
    73         S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
    74         Q:$G(BULL)'="Y"   ;quit if parameter value is not 'Y'es
    75         ;
    76         W !,"Sending bulletin to "_$P($G(^VA(200,ORUSR,0)),U)_"..."
    77         S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(ORUSR)=""
    78         S XMB(1)=ORPNM,XMB(2)=ORSSN,XMB(3)=ORAGE,XMB(4)=$$LTIM($P(OR0,U,7))
    79         D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
    80         S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
    81         S XMB(8)=$$LTIM($P(OR0,U,8)),XMB(9)=$$LTIM($P(OR0,U,9)),XMB(10)=OREASON
    82         S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
    83         D EN^XMB
    84         Q
    85         ;
    86 LTIM(X) ; -- format FM date/time into MM/DD HH:MM
    87         N Y S Y=""
    88         S:X Y=$E(X,4,5)_"/"_$E(X,6,7)
    89         S:X["." Y=Y_" "_$E(X_"0",9,10)_":"_$E(X_"000",11,12)
    90         Q Y
    91         ;
    92 MSG(ORDER)           ; -- Sends HL7 message to Pharmacy when order is un/flagged
    93         Q:'$L($T(OBR^PSJHL4))  ;needs PSJ*5*85
    94         Q:'$G(ORDER)  Q:'$D(^OR(100,+ORDER,0))  Q:'$P(ORDER,";",2)
    95         N OR0,OR3,ORMSG,ORVP,ORX,ORFLAG
    96         S OR0=$G(^OR(100,+ORDER,0)),OR3=$G(^(8,+$P(ORDER,";",2),3))
    97         Q:"^PSJ^PSIV^PSO^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U)  ;Inpt or IV
    98         S ORMSG(1)=$$MSH^ORMBLD("ORU","PS")
    99         S ORVP=$P(OR0,U,2),ORMSG(2)=$$PID^ORMBLD(ORVP)
    100         S ORMSG(3)=$$PV1^ORMBLD(ORVP,$P(OR0,U,12),+$P(OR0,U,10))
    101         S ORX=$S(OR3:$P(OR3,U,3,5),1:$P(OR3,U,6,8))
    102         S ORFLAG=$S(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($P(ORX,U))_"||||||"_$P(ORX,U,3)_"|||"_+$P(ORX,U,2)
    103         S:$G(ORPS) ORFLAG=ORFLAG_"||||||||PHR" ;action taken by pharmacist
    104         S ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$G(^OR(100,+ORDER,4))_"^PS|"_ORFLAG
    105         D MSG^XQOR("OR EVSEND PS",.ORMSG)
    106         Q
     1ORCFLAG ; SLC/MKB - Flag orders ;6/2/97  10:44
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997
     3 ;
     4EN1(ORIFN) ; -- standalone entry point to un/flag order ORIFN
     5 N ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS
     6 Q:'$G(ORIFN)  S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";1"
     7 S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2),DFN=+ORVP I 'ORVP!'$D(^(8,+$P(ORIFN,";",2),0)) W !,"Missing or invalid order!" H 1 Q
     8 D DEM^VADPT S ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2),ORAGE=VADM(4)
     9 S ORACTN=$S($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),3)):"UF",1:"FL")
     10 I '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR) W !,ORERR H 1 Q
     11 S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q
     12 S ORACTN=$S(ORACTN="UF":"UN",1:"EN"),ORPS=1
     13 D @ORACTN,UNLK1^ORX2(+ORIFN)
     14 Q
     15 ;
     16EN ; -- Flag order ORIFN
     17 N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12)
     18 S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to flag!" H 1 Q
     19 S OREASON=$$REASON Q:OREASON="^"
     20 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3),ORNP=$$PROV(ORNP) Q:ORNP="^"
     21 D BULLETIN ;use ORNP?
     22 K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP
     23 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity
     24 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
     25 W !?10,"... order flagged." H 1 D KILL^XM,MSG(ORIFN)
     26 Q
     27 ;
     28UN ; -- Unflag order ORIFN
     29 N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12)
     30 S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to unflag order!" H 1 Q
     31 D SHOWFLAG S OREASON=$$COMMENT Q:OREASON="^"
     32 S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON
     33 S ORNP=+$P(^OR(100,+ORIFN,8,DA,3),U,9) S:'ORNP ORNP=+$P($G(^(0)),U,3)
     34 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
     35 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity
     36 W !?10,"... order unflagged." H 1 D MSG(ORIFN)
     37 Q
     38 ;
     39SHOWFLAG ; -- Display [last] flag for order ORIFN
     40 N FLAG
     41 S FLAG=$G(^OR(100,+ORIFN,8,DA,3))
     42 W !," FLAGGED: "_$$LTIM($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
     43 W !?10,$P(FLAG,U,5) ; reason
     44 Q
     45 ;
     46REASON() ; -- Reason for flag
     47 N X,Y,DIR
     48 S DIR(0)="FA^1:80",DIR("A")="REASON FOR FLAG: " ; ck E3R
     49 S DIR("?")="A reason must be entered to flag this order."
     50 D ^DIR
     51 Q Y
     52 ;
     53COMMENT() ; -- Comments on unflag
     54 N X,Y,DIR
     55 S DIR(0)="FAO^1:80",DIR("A")="COMMENTS: "
     56 S DIR("?")="A comment may be entered to clarify this order."
     57 D ^DIR S:$D(DTOUT) Y="^"
     58 Q Y
     59 ;
     60PROV(ORDR) ; -- Get provider to alert
     61 N X,Y,DIC
     62 S DIC=200,DIC(0)="AEQM",DIC("A")="Send alert to: "
     63 I $G(ORDR) S ORDR=$P($G(^VA(200,+ORDR,0)),U) S:$L(ORDR) DIC("B")=ORDR
     64 S DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)"
     65 D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^"
     66 Q Y
     67 ;
     68BULLETIN ; -- Send bulletin re: flag
     69 N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
     70 S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) ;ORUSR=+$P(OR0,U,4)
     71 S ORUSR=+$G(ORNP),ORSRV=+$P($G(^VA(200,ORUSR,5)),U)
     72 S ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG"
     73 S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
     74 Q:$G(BULL)'="Y"   ;quit if parameter value is not 'Y'es
     75 ;
     76 W !,"Sending bulletin to "_$P($G(^VA(200,ORUSR,0)),U)_"..."
     77 S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(ORUSR)=""
     78 S XMB(1)=ORPNM,XMB(2)=ORSSN,XMB(3)=ORAGE,XMB(4)=$$LTIM($P(OR0,U,7))
     79 D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
     80 S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
     81 S XMB(8)=$$LTIM($P(OR0,U,8)),XMB(9)=$$LTIM($P(OR0,U,9)),XMB(10)=OREASON
     82 S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
     83 D EN^XMB
     84 Q
     85 ;
     86LTIM(X) ; -- format FM date/time into MM/DD HH:MM
     87 N Y S Y=""
     88 S:X Y=$E(X,4,5)_"/"_$E(X,6,7)
     89 S:X["." Y=Y_" "_$E(X_"0",9,10)_":"_$E(X_"000",11,12)
     90 Q Y
     91 ;
     92MSG(ORDER)      ; -- Sends HL7 message to Pharmacy when order is un/flagged
     93 Q:'$L($T(OBR^PSJHL4))  ;needs PSJ*5*85
     94 Q:'$G(ORDER)  Q:'$D(^OR(100,+ORDER,0))  Q:'$P(ORDER,";",2)
     95 N OR0,OR3,ORMSG,ORVP,ORX,ORFLAG
     96 S OR0=$G(^OR(100,+ORDER,0)),OR3=$G(^(8,+$P(ORDER,";",2),3))
     97 Q:"^PSJ^PSIV^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U)  ;Inpt or IV
     98 S ORMSG(1)=$$MSH^ORMBLD("ORU","PS")
     99 S ORVP=$P(OR0,U,2),ORMSG(2)=$$PID^ORMBLD(ORVP)
     100 S ORMSG(3)=$$PV1^ORMBLD(ORVP,$P(OR0,U,12),+$P(OR0,U,10))
     101 S ORX=$S(OR3:$P(OR3,U,3,5),1:$P(OR3,U,6,8))
     102 S ORFLAG=$S(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($P(ORX,U))_"||||||"_$P(ORX,U,3)_"|||"_+$P(ORX,U,2)
     103 S:$G(ORPS) ORFLAG=ORFLAG_"||||||||PHR" ;action taken by pharmacist
     104 S ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$G(^OR(100,+ORDER,4))_"^PS|"_ORFLAG
     105 D MSG^XQOR("OR EVSEND PS",.ORMSG)
     106 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANG2.m

    r613 r623  
    1 ORCHANG2        ;SLC/MKB-Change View status ; 08 May 2002  2:12 PM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,141,215,243**;Dec 17, 1997;Build 242
    3 ORDERS  ; -- Select new order status
    4         N X,Y,HDR,I,DOMAIN,DEFAULT,PROMPT,HELP,STS
    5         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=""
    6         F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ"  D SET
    7         S DOMAIN(0)=I-1,PROMPT="Select Order Status: "
    8         S HELP="Enter the status of orders you wish to see listed here."
    9         D EN Q:Y="^"  S STS=+$G(DOMAIN(Y))
    10         I "^8^9^10^20^"[(U_STS_U) D  Q:Y="^"
    11         . N STRT,STOP,Z
    12         . S STRT=$$START^ORCHANGE("NOW-24H") I STRT="^" S Y="^" Q
    13         . S STOP=$$STOP^ORCHANGE("NOW") I STOP="^" S Y="^" Q
    14         . I STOP<STRT S Z=STRT,STRT=STOP,STOP=Z
    15         . S $P(HDR,";",1,2)=$P(STRT,U,2)_";"_$P(STOP,U,2)
    16         S $P(HDR,";",3)=STS,$P(HDR,";",8)=""
    17         I (STS=2)!(STS=5) D
    18         . I $P(HDR,";")'="" D
    19         . . N THISTS,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
    20         . . S THISTS=" only active "
    21         . . S:STS=5 THISTS=" expiring "
    22         . . W !,"Date range can not be selected when viewing"_THISTS_"orders"
    23         . . W !,"and will be cleared."
    24         . . S DIR(0)="E" D ^DIR
    25         . S $P(HDR,";",1,2)=";"
    26         I STS=6,$P(HDR,";")="" S $P(HDR,";",1,2)="T;T@23:59"
    27         S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    28         Q
    29         ;
    30 STSLST(ORY)         ; -- Returns array of order views as
    31         ;            ORY(n) = id ^ name ^ parent id [^+ if has members]
    32         N I,X,CNT S CNT=0
    33         F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ"  S CNT=CNT+1,ORY(CNT)=$TR($P(X,";",3,6),";","^")
    34         ; include specific patient events??
    35         Q
    36         ;
    37 ORDSTS  ;;#;Name of Order Context
    38         ;;1;All;0;+
    39         ;;2;Active (includes pending, recent activity);1
    40         ;;23;Current (Active & Pending status only);1
    41         ;;3;Discontinued;1
    42         ;;28;Discontinued/Entered in Error;1
    43         ;;4;Completed/Expired;1
    44         ;;5;Expiring;1
    45         ;;7;Pending;1
    46         ;;18;On Hold;1
    47         ;;19;New Orders;1
    48         ;;11;Unsigned;1
    49         ;;8;Unverified by anyone;1;+
    50         ;;9;Unverified by Nursing;8
    51         ;;10;Unverified by Clerk;8
    52         ;;20;Unverified/Chart Review;8
    53         ;;13;Verbal/Phoned;1;+
    54         ;;14;Verbal/Phoned unsigned;13
    55         ;;12;Flagged;1
    56         ;;6;Recent Activity (defaults to today's orders);1
    57         ;;24;Delayed (all events);1;+
    58         ;;15;Delayed Admission;24
    59         ;;17;Delayed Transfer;24
    60         ;;16;Delayed Discharge;24
    61         ;;25;Delayed Return from O.R.;24
    62         ;;26;Delayed for Manual Release;24
    63         ;;22;Lapsed (never processed);1
    64         ;;;ZZZZ
    65         ;
    66 STS     ; -- Select new [order or consult] status
    67         N HDR,DEFAULT,DOMAIN,PROMPT,HELP,X,Y,I
    68         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=""
    69         S (I,Y)=0 F  S I=$O(^ORD(100.01,I)) Q:I'>0  Q:I=99  S X=$G(^(I,0)) D
    70         . Q:"^1^2^5^6^8^9^13^"'[(U_I_U)  S Y=Y+1
    71         . S DOMAIN(Y)=I_U_$$LOWER^VALM1($P(X,U)),DOMAIN("B",$P(X,U))=Y
    72         . S:I=$P(HDR,";",3) DEFAULT=$P(DOMAIN(Y),U,2)
    73         S Y=Y+1,DOMAIN(Y)="^All Statuses",DOMAIN("B","ALL STATUSES")=Y
    74         S DOMAIN(0)=Y,PROMPT="Select Consult Status: "
    75         S HELP="Enter the status of consults you wish to see listed here."
    76         D EN Q:Y="^"
    77         S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    78         Q
    79         ;
    80 TIU     ; -- Select new document status
    81         N X,Y,ORY,I,CNT,HDR,DOMAIN,DEFAULT,PROMPT,HELP
    82         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=$P(HDR,";",3)
    83         D STATUS^TIUSRVL(.ORY)
    84         S (I,CNT)=0 F  S I=$O(ORY(I)) Q:I'>0  S CNT=CNT+1,DOMAIN(CNT)=ORY(I),DOMAIN("B",$$UP^XLFSTR($P(ORY(I),U,2)))=CNT
    85         S DOMAIN(0)=CNT,PROMPT="Select Signature Status: "
    86         S HELP="Enter the signature status you would like to screen on"
    87         D EN Q:Y="^"
    88         S $P(HDR,";",3)=$P(DOMAIN(Y),U,2),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    89         Q
    90         ;
    91 PLIST   ; -- Select problem status
    92         N X,Y,HDR,I,ID,NAME,DOMAIN,DEFAULT,PROMPT,HELP
    93         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3)
    94         F I=1:1 S X=$T(PLSTS+I) Q:$P(X,";",4)="ZZZZ"  D SET
    95         S DOMAIN(0)=I-1,PROMPT="Select Problem Status: "
    96         S HELP="Enter the status of the problems you wish to see listed here."
    97         D EN Q:Y="^"
    98         S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    99         Q
    100         ;
    101 PLSTS   ;;I;name
    102         ;;A;active
    103         ;;I;inactive
    104         ;;B;both active & inactive
    105         ;;;ZZZZ
    106         ;
    107 SET     ; -- set DOMAIN(I)=ID^NAME, DEFAULT from X=";;ID;NAME"
    108         N ID,NAME
    109         S ID=$P(X,";",3),NAME=$P(X,";",4)
    110         S DOMAIN(I)=ID_U_NAME,DOMAIN("B",$$UP^XLFSTR(NAME))=I
    111         S:ID=$P(HDR,";",3) DEFAULT=NAME
    112         Q
    113         ;
    114 EN      ; -- Select new status via DOMAIN(), PROMPT, DEFAULT, HELP
    115         N DONE S DONE=0,Y="" F  D  Q:DONE
    116         . W !,PROMPT_$S($L(DEFAULT):DEFAULT_"//",1:"")
    117         . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q
    118         . S:X="" X=DEFAULT I X="" S Y="^",DONE=1 Q
    119         . I X["?" W !!,HELP D LIST Q
    120         . D  I 'Y W $C(7),!,HELP Q
    121         . . N XP,XY,CNT,MATCH,DIR,I
    122         . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y  ; done
    123         . . S CNT=0,XP=X F  S XP=$O(DOMAIN("B",XP)) Q:XP=""  Q:$E(XP,1,$L(X))'=X  S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2)
    124         . . Q:'CNT
    125         . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q
    126         . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
    127         . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2)
    128         . . S DIR("?")="Select the desired value, by number"
    129         . . I CNT>3 D FULL^VALM1 S VALMBCK="R" ;need to scroll
    130         . . D ^DIR I $D(DIRUT) S Y="" Q
    131         . . S Y=+MATCH(Y) W "  "_$P(DOMAIN(Y),U,2)
    132         . S DONE=1
    133         Q
    134         ;
    135 LIST    ; -- List order statuses in DOMAIN
    136         N I,Z,CNT,DONE D FULL^VALM1 S VALMBCK="R"
    137         S CNT=0 W !,"Choose from:"
    138         F I=1:1:DOMAIN(0) D  Q:$G(DONE)
    139         . S CNT=CNT+1 W ! I CNT>(IOSL-3) D  Q:$G(DONE)
    140         .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1
    141         . W $C(13),"  "_$P(DOMAIN(I),U,2)
    142         Q
     1ORCHANG2 ;SLC/MKB-Change View status ; 08 May 2002  2:12 PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,141,215**;Dec 17, 1997
     3ORDERS ; -- Select new order status
     4 N X,Y,HDR,I,DOMAIN,DEFAULT,PROMPT,HELP,STS
     5 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=""
     6 F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ"  D SET
     7 S DOMAIN(0)=I-1,PROMPT="Select Order Status: "
     8 S HELP="Enter the status of orders you wish to see listed here."
     9 D EN Q:Y="^"  S STS=+$G(DOMAIN(Y))
     10 I "^8^9^10^20^"[(U_STS_U) D  Q:Y="^"
     11 . N STRT,STOP,Z
     12 . S STRT=$$START^ORCHANGE("NOW-24H") I STRT="^" S Y="^" Q
     13 . S STOP=$$STOP^ORCHANGE("NOW") I STOP="^" S Y="^" Q
     14 . I STOP<STRT S Z=STRT,STRT=STOP,STOP=Z
     15 . S $P(HDR,";",1,2)=$P(STRT,U,2)_";"_$P(STOP,U,2)
     16 S $P(HDR,";",3)=STS,$P(HDR,";",8)="" S:STS=2 $P(HDR,";",1,2)=";"
     17 I STS=6,$P(HDR,";")="" S $P(HDR,";",1,2)="T;T@23:59"
     18 S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     19 Q
     20 ;
     21STSLST(ORY)     ; -- Returns array of order views as
     22 ;            ORY(n) = id ^ name ^ parent id [^+ if has members]
     23 N I,X,CNT S CNT=0
     24 F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ"  S CNT=CNT+1,ORY(CNT)=$TR($P(X,";",3,6),";","^")
     25 ; include specific patient events??
     26 Q
     27 ;
     28ORDSTS ;;#;Name of Order Context
     29 ;;1;All;0;+
     30 ;;2;Active (includes pending, recent activity);1
     31 ;;23;Current (Active & Pending status only);1
     32 ;;3;Discontinued;1
     33 ;;28;Discontinued/Entered in Error;1
     34 ;;4;Completed/Expired;1
     35 ;;5;Expiring;1
     36 ;;7;Pending;1
     37 ;;18;On Hold;1
     38 ;;19;New Orders;1
     39 ;;11;Unsigned;1
     40 ;;8;Unverified by anyone;1;+
     41 ;;9;Unverified by Nursing;8
     42 ;;10;Unverified by Clerk;8
     43 ;;20;Unverified/Chart Review;8
     44 ;;13;Verbal/Phoned;1;+
     45 ;;14;Verbal/Phoned unsigned;13
     46 ;;12;Flagged;1
     47 ;;6;Recent Activity (defaults to today's orders);1
     48 ;;24;Delayed (all events);1;+
     49 ;;15;Delayed Admission;24
     50 ;;17;Delayed Transfer;24
     51 ;;16;Delayed Discharge;24
     52 ;;25;Delayed Return from O.R.;24
     53 ;;26;Delayed for Manual Release;24
     54 ;;22;Lapsed (never processed);1
     55 ;;;ZZZZ
     56 ;
     57STS ; -- Select new [order or consult] status
     58 N HDR,DEFAULT,DOMAIN,PROMPT,HELP,X,Y,I
     59 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=""
     60 S (I,Y)=0 F  S I=$O(^ORD(100.01,I)) Q:I'>0  Q:I=99  S X=$G(^(I,0)) D
     61 . Q:"^1^2^5^6^8^9^13^"'[(U_I_U)  S Y=Y+1
     62 . S DOMAIN(Y)=I_U_$$LOWER^VALM1($P(X,U)),DOMAIN("B",$P(X,U))=Y
     63 . S:I=$P(HDR,";",3) DEFAULT=$P(DOMAIN(Y),U,2)
     64 S Y=Y+1,DOMAIN(Y)="^All Statuses",DOMAIN("B","ALL STATUSES")=Y
     65 S DOMAIN(0)=Y,PROMPT="Select Consult Status: "
     66 S HELP="Enter the status of consults you wish to see listed here."
     67 D EN Q:Y="^"
     68 S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     69 Q
     70 ;
     71TIU ; -- Select new document status
     72 N X,Y,ORY,I,CNT,HDR,DOMAIN,DEFAULT,PROMPT,HELP
     73 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=$P(HDR,";",3)
     74 D STATUS^TIUSRVL(.ORY)
     75 S (I,CNT)=0 F  S I=$O(ORY(I)) Q:I'>0  S CNT=CNT+1,DOMAIN(CNT)=ORY(I),DOMAIN("B",$$UP^XLFSTR($P(ORY(I),U,2)))=CNT
     76 S DOMAIN(0)=CNT,PROMPT="Select Signature Status: "
     77 S HELP="Enter the signature status you would like to screen on"
     78 D EN Q:Y="^"
     79 S $P(HDR,";",3)=$P(DOMAIN(Y),U,2),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     80 Q
     81 ;
     82PLIST ; -- Select problem status
     83 N X,Y,HDR,I,ID,NAME,DOMAIN,DEFAULT,PROMPT,HELP
     84 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3)
     85 F I=1:1 S X=$T(PLSTS+I) Q:$P(X,";",4)="ZZZZ"  D SET
     86 S DOMAIN(0)=I-1,PROMPT="Select Problem Status: "
     87 S HELP="Enter the status of the problems you wish to see listed here."
     88 D EN Q:Y="^"
     89 S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     90 Q
     91 ;
     92PLSTS ;;I;name
     93 ;;A;active
     94 ;;I;inactive
     95 ;;B;both active & inactive
     96 ;;;ZZZZ
     97 ;
     98SET ; -- set DOMAIN(I)=ID^NAME, DEFAULT from X=";;ID;NAME"
     99 N ID,NAME
     100 S ID=$P(X,";",3),NAME=$P(X,";",4)
     101 S DOMAIN(I)=ID_U_NAME,DOMAIN("B",$$UP^XLFSTR(NAME))=I
     102 S:ID=$P(HDR,";",3) DEFAULT=NAME
     103 Q
     104 ;
     105EN ; -- Select new status via DOMAIN(), PROMPT, DEFAULT, HELP
     106 N DONE S DONE=0,Y="" F  D  Q:DONE
     107 . W !,PROMPT_$S($L(DEFAULT):DEFAULT_"//",1:"")
     108 . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q
     109 . S:X="" X=DEFAULT I X="" S Y="^",DONE=1 Q
     110 . I X["?" W !!,HELP D LIST Q
     111 . D  I 'Y W $C(7),!,HELP Q
     112 . . N XP,XY,CNT,MATCH,DIR,I
     113 . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y  ; done
     114 . . S CNT=0,XP=X F  S XP=$O(DOMAIN("B",XP)) Q:XP=""  Q:$E(XP,1,$L(X))'=X  S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2)
     115 . . Q:'CNT
     116 . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q
     117 . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
     118 . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2)
     119 . . S DIR("?")="Select the desired value, by number"
     120 . . I CNT>3 D FULL^VALM1 S VALMBCK="R" ;need to scroll
     121 . . D ^DIR I $D(DIRUT) S Y="" Q
     122 . . S Y=+MATCH(Y) W "  "_$P(DOMAIN(Y),U,2)
     123 . S DONE=1
     124 Q
     125 ;
     126LIST ; -- List order statuses in DOMAIN
     127 N I,Z,CNT,DONE D FULL^VALM1 S VALMBCK="R"
     128 S CNT=0 W !,"Choose from:"
     129 F I=1:1:DOMAIN(0) D  Q:$G(DONE)
     130 . S CNT=CNT+1 W ! I CNT>(IOSL-3) D  Q:$G(DONE)
     131 .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1
     132 . W $C(13),"  "_$P(DOMAIN(I),U,2)
     133 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANGE.m

    r613 r623  
    1 ORCHANGE        ;SLC/MKB-Change View utilities ; 08 May 2002  2:12 PM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,141,243**;Dec 17, 1997;Build 242
    3 EN      ; -- Change view of current list
    4         N XQORM,Y,ORI
    5         S XQORM=$G(^TMP("OR",$J,"CURRENT","CHANGE")),VALMBCK=""
    6         I 'XQORM W !!,"No other views of this list currently available" H 2 Q
    7         S Y=$S(ORTAB="NOTES"!(ORTAB="SUMMRIES"):"1\",ORTAB="ORDERS":"\",1:"")
    8         S XQORM(0)=Y_"AD" K Y
    9         S XQORM("A")=$S($L($G(^ORD(101,+XQORM,28))):^(28),1:"Select attribute(s) to change: ")
    10         D EN^XQORM S ORI=0
    11         F  S ORI=$O(Y(ORI)) Q:ORI'>0  X:$D(^ORD(101,+$P(Y(ORI),U,2),20)) ^(20)
    12         I $G(^TMP("OR",$J,"CURRENT",0))'=$G(^TMP("OR",$J,ORTAB,0)) K VALMBG D TAB^ORCHART(ORTAB,1)
    13         Q
    14         ;
    15 RANGE   ; -- Get new date range for list
    16         N HDR,OLD,NEW,REQ,BEG,END
    17         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3)
    18         S REQ=$S(ORTAB="XRAYS":1,ORTAB="REPORTS":1,1:0)
    19         I ($P(HDR,";",3)=2)!($P(HDR,";",3)=5) D  Q
    20         . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,THISTS
    21         . S THISTS=" only active "
    22         . I $P(HDR,";",3)=5 S THISTS=" expiring "
    23         . W !,"Date range can not be selected when viewing"_THISTS_"orders."
    24         . S DIR(0)="E" D ^DIR
    25         S OLD=$P(HDR,";"),NEW=$$START(OLD,REQ) Q:NEW="^"  S BEG=NEW
    26         I BEG="" S END="" G RQ
    27         S OLD=$P(HDR,";",2),NEW=$$STOP(OLD,REQ) Q:NEW="^"  S END=NEW
    28         I END<BEG S NEW=END,END=BEG,BEG=NEW ; switch
    29 RQ      S $P(HDR,";",1,2)=$P(BEG,U,2)_";"_$P(END,U,2)
    30         S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    31         Q
    32         ;
    33 START(CURRENT,REQD)     ; -- Return new beginning date
    34         N X,Y,DIR
    35         S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Beginning Date[/time]: "
    36         S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT)
    37         S DIR("?")="Enter the earliest date [and time] from which you want to see data; a null response will return all data on this patient"
    38         D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X
    39         Q Y
    40         ;
    41 STOP(CURRENT,REQD)      ; -- Return new ending date
    42         N X,Y,DIR
    43         S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Ending Date[/time]: "
    44         S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT)
    45         S DIR("?")="Enter the latest date [and time] for which you want to see data; a null response will assume TODAY"
    46         D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X
    47         Q Y
    48         ;
    49 MAX     ; -- Get new max # of items to list
    50         N X,Y,DIR
    51         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),X=$P(HDR,";",5)
    52         S DIR(0)="NAO^1:999" S:X DIR("B")=X
    53         S DIR("A")="Maximum # of items to display: "
    54         S DIR("?")="Enter the total number of items you wish to be displayed here"
    55         D ^DIR Q:'Y
    56         S $P(HDR,";",5)=Y,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    57         Q
    58         ;
    59 AUTHOR(USER)    ; -- Select new author of note
    60         N X,Y,DIC D FULL^VALM1 S VALMBCK="R"
    61         S DIC=200,DIC(0)="AEQM",DIC("A")="Select AUTHOR: "
    62         S:$G(USER) DIC("B")=$P($G(^VA(200,+USER,0)),U)
    63         D ^DIC S:Y'>0 Y=""
    64         Q +Y
    65         ;
    66 LISTHDR ; -- List available subhdrs
    67         N HDR,DONE,CNT D FULL^VALM1
    68         W !!,"Choose from:" S HDR="",(CNT,DONE)=0,VALMBCK="R"
    69         F  S HDR=$O(^TMP("OR",$J,"CURRENT","HDR",HDR)) Q:HDR=""  D  Q:DONE
    70         . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q
    71         . W !,"  "_HDR
    72         Q
    73         ;
    74 LRSUB   ; -- Return lab subscript to jump to in list
    75         ;    Available subscripts in ^TMP("OR",$J,"IDX",name)=line #
    76         I '$D(^TMP("OR",$J,"CURRENT","HDR")) W !!,"There are no section headers defined for this report." H 3 Q
    77         N X,Y,DIR,XP,P,CNT,MATCH D FULL^VALM1 S VALMBCK="R"
    78 LRS     S DIR(0)="FAO^1:30",DIR("A")="Select Lab Section: "
    79         S DIR("A",1)="Available sections in this report:",X=""
    80         F I=2:1 S X=$O(^TMP("OR",$J,"CURRENT","HDR",X)) Q:X=""  S DIR("A",I)="   "_X
    81         S DIR("?")="Enter the lab section from which to wish to see results; the display will scroll to the top of the selected section" ;,DIR("??")="^D LISTHDR^ORCHANGE"
    82         D ^DIR Q:"^"[Y
    83         S XP=$$UP^XLFSTR(X)
    84         I $G(^TMP("OR",$J,"CURRENT","HDR",XP)) S VALMBG=^(XP),VALMBCK="R" Q
    85         S CNT=0,P=XP F  S P=$O(^TMP("OR",$J,"CURRENT","HDR",P)) Q:$E(P,1,$L(XP))'=XP  S CNT=CNT+1,MATCH(CNT)=+$G(^(P))_U_P ; line# ^ hdr name
    86         I 'CNT W $C(7),"  ??" G LRS
    87         I CNT=1 S VALMBG=+MATCH(CNT),VALMBCK="R",P=$P(MATCH(1),U,2) W $E(P,$L(X)+1,$L(P)) Q
    88 LRS1    K DIR S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
    89         F I=1:1:CNT S DIR("A",I)=I_"  "_$P(MATCH(I),U,2)
    90         S DIR("?")="Select the lab section you want to go to, by number"
    91         D ^DIR Q:$D(DTOUT)!($D(DUOUT))  I 'Y K DIR G LRS
    92         S VALMBG=+MATCH(Y),VALMBCK="R"
    93         Q
    94         ;
    95 DGROUP  ; -- Select new service (display group)
    96         N X,Y,Z,ZZ,DIC,HDR,DONE,HELP
    97         D FULL^VALM1 S VALMBCK="R"
    98         S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),Z=$P(HDR,";",4),ZZ=+$O(^ORD(100.98,"B",$S($L(Z):Z,1:"ALL"),0))
    99         S HELP="Enter the service or section from which you wish to see orders for this patient."
    100         S DONE=0 F  D  Q:DONE
    101         . W !!,"Select Service/Section: "_$P(^ORD(100.98,+ZZ,0),U)_"//"
    102         . R X:DTIME S:'$T X="^" I X["^" S DONE=1 Q
    103         . I X="" S DONE=1 Q  ; no change
    104         . I X["?" W !!,HELP,!,"Choose from:" D DG^ORCHANG1(1,"DISP") Q
    105         . S DIC=100.98,DIC(0)="NEQZ" D ^DIC S:Y>0 Z=$P(Y(0),U,3),ZZ=+Y,DONE=1
    106         S $P(HDR,";",4)=Z,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
    107         Q
    108         ;
    109 CS      ; -- Select new consult service
    110         N GMRCDG,GMRCBUF,GMRCACT,GMRCQUT,GMRCGRP,HDR
    111         D FULL^VALM1,ASRV^GMRCASV S VALMBCK="R" Q:$D(GMRCQUT)
    112         S:$G(GMRCDG) HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),$P(HDR,";",4)=GMRCDG,$P(^(0),U,3,4)=HDR_U
    113         K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
    114         Q
    115         ;
    116 REMOVE  ; -- Remove preferred view
    117         N ORDEL S ORDEL=1
    118 SAVE    ; -- Save current view as preferred
    119         Q:'$$OK($G(ORDEL))  N X,Y,PARAM
    120         S X=$S($G(ORDEL):"@",1:$P($G(^TMP("OR",$J,ORTAB,0)),U,3)),Y=""
    121         ;S:$G(ORTAB)="MEDS" Y=$S($P(X,";",3):"IN",1:"OUT")_"PT "
    122         S:$G(ORTAB)="LABS" Y=$S($G(ORWARD):"IN",1:"OUT")_"PT "
    123         S PARAM="ORCH CONTEXT "_Y_$G(ORTAB)
    124         D EN^XPAR("USR",PARAM,1,X) W " ...done." H 1
    125         Q
    126         ;
    127 OK(DEL) ; -- Are you sure you want to save/remove view of ORTAB?
    128         N X,Y,DIR S DIR(0)="YA"
    129         S DIR("A")="Are you sure you want to "_$S($G(DEL):"remove",1:"save the current view as")_" your preference? "
    130         S:$G(DEL) DIR("?",1)="Enter YES if you wish to remove your preferred view of this chart tab and use",DIR("?")="the default view next time, or NO to quit without changing anything."
    131         S:'$G(DEL) DIR("?",1)="Enter YES if you wish to use these same parameters again the next time the ",DIR("?")=$$LOWER^VALM1(ORTAB)_" tab is created for you, or NO to quit without saving anything."
    132         D ^DIR
    133         Q +Y
    134         ;
    135 RETURN  ; -- Return to preferred view of ORTAB
    136         S $P(^TMP("OR",$J,ORTAB,0),U,4)=1
    137         Q
     1ORCHANGE ;SLC/MKB-Change View utilities ; 08 May 2002  2:12 PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,141**;Dec 17, 1997
     3EN ; -- Change view of current list
     4 N XQORM,Y,ORI
     5 S XQORM=$G(^TMP("OR",$J,"CURRENT","CHANGE")),VALMBCK=""
     6 I 'XQORM W !!,"No other views of this list currently available" H 2 Q
     7 S Y=$S(ORTAB="NOTES"!(ORTAB="SUMMRIES"):"1\",ORTAB="ORDERS":"\",1:"")
     8 S XQORM(0)=Y_"AD" K Y
     9 S XQORM("A")=$S($L($G(^ORD(101,+XQORM,28))):^(28),1:"Select attribute(s) to change: ")
     10 D EN^XQORM S ORI=0
     11 F  S ORI=$O(Y(ORI)) Q:ORI'>0  X:$D(^ORD(101,+$P(Y(ORI),U,2),20)) ^(20)
     12 I $G(^TMP("OR",$J,"CURRENT",0))'=$G(^TMP("OR",$J,ORTAB,0)) K VALMBG D TAB^ORCHART(ORTAB,1)
     13 Q
     14 ;
     15RANGE ; -- Get new date range for list
     16 N HDR,OLD,NEW,REQ
     17 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3)
     18 S REQ=$S(ORTAB="XRAYS":1,ORTAB="REPORTS":1,1:0)
     19 I $P(HDR,";",3)=2 D  Q
     20 . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
     21 . W !,"Date range can not be selected when viewing only active orders"
     22 . S DIR(0)="E" D ^DIR
     23 S OLD=$P(HDR,";"),NEW=$$START(OLD,REQ) Q:NEW="^"  S BEG=NEW
     24 I BEG="" S END="" G RQ
     25 S OLD=$P(HDR,";",2),NEW=$$STOP(OLD,REQ) Q:NEW="^"  S END=NEW
     26 I END<BEG S NEW=END,END=BEG,BEG=NEW ; switch
     27RQ S $P(HDR,";",1,2)=$P(BEG,U,2)_";"_$P(END,U,2)
     28 S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     29 Q
     30 ;
     31START(CURRENT,REQD) ; -- Return new beginning date
     32 N X,Y,DIR
     33 S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Beginning Date[/time]: "
     34 S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT)
     35 S DIR("?")="Enter the earliest date [and time] from which you want to see data; a null response will return all data on this patient"
     36 D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X
     37 Q Y
     38 ;
     39STOP(CURRENT,REQD) ; -- Return new ending date
     40 N X,Y,DIR
     41 S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Ending Date[/time]: "
     42 S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT)
     43 S DIR("?")="Enter the latest date [and time] for which you want to see data; a null response will assume TODAY"
     44 D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X
     45 Q Y
     46 ;
     47MAX ; -- Get new max # of items to list
     48 N X,Y,DIR
     49 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),X=$P(HDR,";",5)
     50 S DIR(0)="NAO^1:999" S:X DIR("B")=X
     51 S DIR("A")="Maximum # of items to display: "
     52 S DIR("?")="Enter the total number of items you wish to be displayed here"
     53 D ^DIR Q:'Y
     54 S $P(HDR,";",5)=Y,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     55 Q
     56 ;
     57AUTHOR(USER) ; -- Select new author of note
     58 N X,Y,DIC D FULL^VALM1 S VALMBCK="R"
     59 S DIC=200,DIC(0)="AEQM",DIC("A")="Select AUTHOR: "
     60 S:$G(USER) DIC("B")=$P($G(^VA(200,+USER,0)),U)
     61 D ^DIC S:Y'>0 Y=""
     62 Q +Y
     63 ;
     64LISTHDR ; -- List available subhdrs
     65 N HDR,DONE,CNT D FULL^VALM1
     66 W !!,"Choose from:" S HDR="",(CNT,DONE)=0,VALMBCK="R"
     67 F  S HDR=$O(^TMP("OR",$J,"CURRENT","HDR",HDR)) Q:HDR=""  D  Q:DONE
     68 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q
     69 . W !,"  "_HDR
     70 Q
     71 ;
     72LRSUB ; -- Return lab subscript to jump to in list
     73 ;    Available subscripts in ^TMP("OR",$J,"IDX",name)=line #
     74 I '$D(^TMP("OR",$J,"CURRENT","HDR")) W !!,"There are no section headers defined for this report." H 3 Q
     75 N X,Y,DIR,XP,P,CNT,MATCH D FULL^VALM1 S VALMBCK="R"
     76LRS S DIR(0)="FAO^1:30",DIR("A")="Select Lab Section: "
     77 S DIR("A",1)="Available sections in this report:",X=""
     78 F I=2:1 S X=$O(^TMP("OR",$J,"CURRENT","HDR",X)) Q:X=""  S DIR("A",I)="   "_X
     79 S DIR("?")="Enter the lab section from which to wish to see results; the display will scroll to the top of the selected section" ;,DIR("??")="^D LISTHDR^ORCHANGE"
     80 D ^DIR Q:"^"[Y
     81 S XP=$$UP^XLFSTR(X)
     82 I $G(^TMP("OR",$J,"CURRENT","HDR",XP)) S VALMBG=^(XP),VALMBCK="R" Q
     83 S CNT=0,P=XP F  S P=$O(^TMP("OR",$J,"CURRENT","HDR",P)) Q:$E(P,1,$L(XP))'=XP  S CNT=CNT+1,MATCH(CNT)=+$G(^(P))_U_P ; line# ^ hdr name
     84 I 'CNT W $C(7),"  ??" G LRS
     85 I CNT=1 S VALMBG=+MATCH(CNT),VALMBCK="R",P=$P(MATCH(1),U,2) W $E(P,$L(X)+1,$L(P)) Q
     86LRS1 K DIR S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
     87 F I=1:1:CNT S DIR("A",I)=I_"  "_$P(MATCH(I),U,2)
     88 S DIR("?")="Select the lab section you want to go to, by number"
     89 D ^DIR Q:$D(DTOUT)!($D(DUOUT))  I 'Y K DIR G LRS
     90 S VALMBG=+MATCH(Y),VALMBCK="R"
     91 Q
     92 ;
     93DGROUP ; -- Select new service (display group)
     94 N X,Y,Z,ZZ,DIC,HDR,DONE,HELP
     95 D FULL^VALM1 S VALMBCK="R"
     96 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),Z=$P(HDR,";",4),ZZ=+$O(^ORD(100.98,"B",$S($L(Z):Z,1:"ALL"),0))
     97 S HELP="Enter the service or section from which you wish to see orders for this patient."
     98 S DONE=0 F  D  Q:DONE
     99 . W !!,"Select Service/Section: "_$P(^ORD(100.98,+ZZ,0),U)_"//"
     100 . R X:DTIME S:'$T X="^" I X["^" S DONE=1 Q
     101 . I X="" S DONE=1 Q  ; no change
     102 . I X["?" W !!,HELP,!,"Choose from:" D DG^ORCHANG1(1,"DISP") Q
     103 . S DIC=100.98,DIC(0)="NEQZ" D ^DIC S:Y>0 Z=$P(Y(0),U,3),ZZ=+Y,DONE=1
     104 S $P(HDR,";",4)=Z,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U
     105 Q
     106 ;
     107CS ; -- Select new consult service
     108 N GMRCDG,GMRCBUF,GMRCACT,GMRCQUT,GMRCGRP,HDR
     109 D FULL^VALM1,ASRV^GMRCASV S VALMBCK="R" Q:$D(GMRCQUT)
     110 S:$G(GMRCDG) HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),$P(HDR,";",4)=GMRCDG,$P(^(0),U,3,4)=HDR_U
     111 K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
     112 Q
     113 ;
     114REMOVE ; -- Remove preferred view
     115 N ORDEL S ORDEL=1
     116SAVE ; -- Save current view as preferred
     117 Q:'$$OK($G(ORDEL))  N X,Y,PARAM
     118 S X=$S($G(ORDEL):"@",1:$P($G(^TMP("OR",$J,ORTAB,0)),U,3)),Y=""
     119 ;S:$G(ORTAB)="MEDS" Y=$S($P(X,";",3):"IN",1:"OUT")_"PT "
     120 S:$G(ORTAB)="LABS" Y=$S($G(ORWARD):"IN",1:"OUT")_"PT "
     121 S PARAM="ORCH CONTEXT "_Y_$G(ORTAB)
     122 D EN^XPAR("USR",PARAM,1,X) W " ...done." H 1
     123 Q
     124 ;
     125OK(DEL) ; -- Are you sure you want to save/remove view of ORTAB?
     126 N X,Y,DIR S DIR(0)="YA"
     127 S DIR("A")="Are you sure you want to "_$S($G(DEL):"remove",1:"save the current view as")_" your preference? "
     128 S:$G(DEL) DIR("?",1)="Enter YES if you wish to remove your preferred view of this chart tab and use",DIR("?")="the default view next time, or NO to quit without changing anything."
     129 S:'$G(DEL) DIR("?",1)="Enter YES if you wish to use these same parameters again the next time the ",DIR("?")=$$LOWER^VALM1(ORTAB)_" tab is created for you, or NO to quit without saving anything."
     130 D ^DIR
     131 Q +Y
     132 ;
     133RETURN ; -- Return to preferred view of ORTAB
     134 S $P(^TMP("OR",$J,ORTAB,0),U,4)=1
     135 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHECK.m

    r613 r623  
    1 ORCHECK ;SLC/MKB-Order checking calls ; 08 May 2002  2:12 PM [8/16/05 5:28am]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED]
    5         ;    Expects ORVP, ORNMSP, ORTAB, [ORWARD]
    6         Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
    7         N ORX,ORY,I
    8         I ORNMSP="PS" D  ;reset to PSJ, PSJI, or PSO
    9         . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I)  S ORNMSP="PS"_$S(I="UD":"I",1:I) Q
    10         . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list
    11         S ORX(1)="|"_ORNMSP,ORX=1
    12         D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY)
    13         S I=0 F  S I=$O(ORY(I)) Q:I'>0  W !,$P(ORY(I),U,4) ; display only
    14         Q
    15         ;
    16 SELECT  ; -- SELECT event
    17         ;    Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP
    18         Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
    19         N ORX,ORY,OI
    20         S OI=+$G(ORDIALOG(PROMPT,ORI))
    21         S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI)
    22         D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY)
    23         Q
    24         ;
    25 ACCEPT(MODE)    ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED]
    26         ;    Expects ORVP, ORDIALOG(), ORNMSP
    27         Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
    28         N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP
    29         S:'$L($G(MODE)) MODE="ACCEPT"
    30         S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0
    31         S ORI=0 F  S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0  D STUF
    32         I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F  S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0  D STUF
    33         D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY)
    34         Q
    35 STUF    S ORIT=ORDIALOG(OI,ORI),ORSP=""
    36         S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI))
    37         S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT))
    38         S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID
    39         I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY)
    40         S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ
    41         Q
    42         ;
    43 DELAY(MODE)     ; -- Delayed ACCEPT event [called from ORMEVNT]
    44         ;    Expects ORVP, ORIFN
    45         Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
    46         N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF"
    47         D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY)
    48         D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q  ; silent
    49         Q
    50         ;
    51 SESSION ; -- SESSION event [called from ORCSIGN]
    52         ;    Expects ORVP, ORES()
    53         Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
    54         N ORX,ORY,ORIFN,I,X,Y
    55         S ORIFN=0 F  S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0  I +$P(ORIFN,";",2)'>1 D
    56         . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q  ;unreleased
    57         . D BLD(+ORIFN) Q:'$D(^OR(100,+ORIFN,9))
    58         . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1
    59         . S I=0 F  S I=$O(^OR(100,+ORIFN,9,I)) Q:I'>0  S X=$G(^(I,0)),Y=$G(^(1)),ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($P(X,U,2):$P(X,U,2),1:99),ORCHECK)=$P(X,U,1,2)_U_Y
    60         I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS
    61         Q
    62         ;
    63 BLD(ORDER)      ; -- Build new ORX(#) for ORDER
    64         Q:'$G(ORDER)  Q:'$D(^OR(100,ORDER,0))  ;Q:$P($G(^(3)),U,11)  ;edit/renew
    65         N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST
    66         S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1)
    67         I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI)
    68         S START=$$START(ORDER),ORI=0
    69         F  S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0  D
    70         . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1))
    71         . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM))
    72         . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"")
    73         . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC
    74         Q
    75         ;
    76 RETURN  ; -- Return checks in ORCHECK(ORIFN,CDL,#)
    77         N I,IFN,CDL S I=0 F  S I=$O(ORY(I)) Q:I'>0  D
    78         . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW"
    79         . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99
    80         . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count
    81         . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4)
    82         Q
    83         ;
    84 REMDUPS ;
    85         N IFN,CDL,I
    86         S IFN=0 F  S IFN=$O(ORCHECK(IFN)) Q:'IFN  D
    87         . S CDL=0 F  S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL  D
    88         . . S I=0 F  S I=$O(ORCHECK(IFN,CDL,I)) Q:'I  D
    89         . . . S J=I F  S J=$O(ORCHECK(IFN,CDL,J)) Q:'J  I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1
    90         Q
    91 START(DA)       ; -- Returns start date/time
    92         N I,X,Y,%DT S Y=""
    93         I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1))
    94         E  D  ; look in ORDIALOG instead
    95         . S I=0 F  S I=$O(ORDIALOG(I)) Q:I'>0  Q:$P(ORDIALOG(I),U,2)="START"
    96         . S X=$S(I:$G(ORDIALOG(I,1)),1:"")
    97         D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT"
    98         D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST"
    99         I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y=""
    100         Q Y
    101         ;
    102 DRUG(OI,PTR,IFN)        ; -- Returns 6 ^-piece identifier for Dispense Drug
    103         N ORDD,ORNDF,Y
    104         I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1
    105         I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1))
    106         E  S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
    107 D1      Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD)
    108         S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$$NAME50^ORPEAPI(ORDD)_"^99PSD"
    109         Q Y
    110         ;
    111 IV()    ; -- Get Dispense Drug for IV orderable
    112         N PSOI,TYPE,VOL,ORY
    113         S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL=""
    114         S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B")
    115         S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1)))
    116         D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY)
    117         Q +$G(ORY)
    118         ;
    119 LIST(IFN)       ; -- Displays list of ORCHECK(IFN) checks
    120         N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF
    121         S ORZ=0 F  S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0  D
    122         . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High
    123         . S ORI=0 F  S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0  D
    124         . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>>  "_X_OFF Q
    125         . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX)  ; wrap
    126         . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>>  ",1:"      ")_ORTX(ORJ)_OFF
    127         W !
    128         Q
    129         ;
    130 CANCEL()        ; -- Returns 1 or 0: Cancel order(s)?
    131         N X,Y,DIR,NUM
    132         S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA"
    133         S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ")
    134         S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order.  If you wish to override these order checks"
    135         S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks."
    136         D ^DIR
    137         Q +Y
    138         ;
    139 REASON()        ; -- Reason for overriding order checks
    140         ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q  ??
    141         N X,Y,DIR
    142         S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: "
    143         S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters"
    144         D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^"
    145         Q Y
    146 OCAPI(IFN,ORPLACE)      ;IA #4859
    147         ;API to get the order checking info for a specific order (IFN)
    148         ;info is stored in ^TMP($J,ORPLACE)
    149         ;               ^TMP($J,ORPLACE,D0,"OC LEVEL")="order check level"
    150         ;                                                 ,"OC TEXT")="order check text"
    151         ;                                                 ,"OR REASON")="over ride reason text"
    152         ;                                                 ,"OR PROVIDER")="provider DUZ who entered over ride reason"
    153         ;                                                 ,"OR DT")="date/time over ride reason was entered"
    154         ; NOTE on OC LEVEL: 1 is HIGH, 2 is MODERATE, 3 is LOW
    155         I '$D(^OR(100,IFN,9)) Q
    156         N I
    157         S I=0 F  S I=$O(^OR(100,IFN,9,I)) Q:'I  D
    158         .S ^TMP($J,ORPLACE,I,"OC LEVEL")=$P($G(^OR(100,IFN,9,I,0)),U,2)
    159         .S ^TMP($J,ORPLACE,I,"OC TEXT")=$G(^OR(100,IFN,9,I,1))
    160         .S ^TMP($J,ORPLACE,I,"OR REASON")=$P($G(^OR(100,IFN,9,I,0)),U,4)
    161         .S ^TMP($J,ORPLACE,I,"OR PROVIDER")=$P($G(^OR(100,IFN,9,I,0)),U,5)
    162         .S ^TMP($J,ORPLACE,I,"OR DT")=$P($G(^OR(100,IFN,9,I,0)),U,6)
    163         Q
     1ORCHECK ;SLC/MKB-Order checking calls ; 08 May 2002  2:12 PM [8/16/05 5:28am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215**;Dec 17, 1997
     3DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED]
     4 ;    Expects ORVP, ORNMSP, ORTAB, [ORWARD]
     5 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
     6 N ORX,ORY,I
     7 I ORNMSP="PS" D  ;reset to PSJ, PSJI, or PSO
     8 . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I)  S ORNMSP="PS"_$S(I="UD":"I",1:I) Q
     9 . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list
     10 S ORX(1)="|"_ORNMSP,ORX=1
     11 D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY)
     12 S I=0 F  S I=$O(ORY(I)) Q:I'>0  W !,$P(ORY(I),U,4) ; display only
     13 Q
     14 ;
     15SELECT ; -- SELECT event
     16 ;    Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP
     17 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
     18 N ORX,ORY,OI
     19 S OI=+$G(ORDIALOG(PROMPT,ORI))
     20 S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI)
     21 D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY)
     22 Q
     23 ;
     24ACCEPT(MODE) ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED]
     25 ;    Expects ORVP, ORDIALOG(), ORNMSP
     26 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
     27 N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP
     28 S:'$L($G(MODE)) MODE="ACCEPT"
     29 S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0
     30 S ORI=0 F  S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0  D STUF
     31 I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F  S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0  D STUF
     32 D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY)
     33 Q
     34STUF S ORIT=ORDIALOG(OI,ORI),ORSP=""
     35 S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI))
     36 S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT))
     37 S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID
     38 I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY)
     39 S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ
     40 Q
     41 ;
     42DELAY(MODE) ; -- Delayed ACCEPT event [called from ORMEVNT]
     43 ;    Expects ORVP, ORIFN
     44 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
     45 N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF"
     46 D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY)
     47 D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q  ; silent
     48 Q
     49 ;
     50SESSION ; -- SESSION event [called from ORCSIGN]
     51 ;    Expects ORVP, ORES()
     52 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
     53 N ORX,ORY,ORIFN,I,X,Y
     54 S ORIFN=0 F  S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0  I +$P(ORIFN,";",2)'>1 D
     55 . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q  ;unreleased
     56 . D BLD(+ORIFN) Q:'$D(^OR(100,+ORIFN,9))
     57 . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1
     58 . S I=0 F  S I=$O(^OR(100,+ORIFN,9,I)) Q:I'>0  S X=$G(^(I,0)),Y=$G(^(1)),ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($P(X,U,2):$P(X,U,2),1:99),ORCHECK)=$P(X,U,1,2)_U_Y
     59 I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS
     60 Q
     61 ;
     62BLD(ORDER) ; -- Build new ORX(#) for ORDER
     63 Q:'$G(ORDER)  Q:'$D(^OR(100,ORDER,0))  ;Q:$P($G(^(3)),U,11)  ;edit/renew
     64 N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST
     65 S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1)
     66 I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI)
     67 S START=$$START(ORDER),ORI=0
     68 F  S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0  D
     69 . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1))
     70 . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM))
     71 . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"")
     72 . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC
     73 Q
     74 ;
     75RETURN ; -- Return checks in ORCHECK(ORIFN,CDL,#)
     76 N I,IFN,CDL S I=0 F  S I=$O(ORY(I)) Q:I'>0  D
     77 . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW"
     78 . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99
     79 . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count
     80 . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4)
     81 Q
     82 ;
     83REMDUPS ;
     84 N IFN,CDL,I
     85 S IFN=0 F  S IFN=$O(ORCHECK(IFN)) Q:'IFN  D
     86 . S CDL=0 F  S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL  D
     87 . . S I=0 F  S I=$O(ORCHECK(IFN,CDL,I)) Q:'I  D
     88 . . . S J=I F  S J=$O(ORCHECK(IFN,CDL,J)) Q:'J  I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1
     89 Q
     90START(DA) ; -- Returns start date/time
     91 N I,X,Y,%DT S Y=""
     92 I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1))
     93 E  D  ; look in ORDIALOG instead
     94 . S I=0 F  S I=$O(ORDIALOG(I)) Q:I'>0  Q:$P(ORDIALOG(I),U,2)="START"
     95 . S X=$S(I:$G(ORDIALOG(I,1)),1:"")
     96 D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT"
     97 D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST"
     98 I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y=""
     99 Q Y
     100 ;
     101DRUG(OI,PTR,IFN) ; -- Returns 6 ^-piece identifier for Dispense Drug
     102 N ORDD,ORNDF,Y
     103 I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1
     104 I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1))
     105 E  S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
     106D1 Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD)
     107 S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$P($G(^PSDRUG(ORDD,0)),U)_"^99PSD"
     108 Q Y
     109 ;
     110IV() ; -- Get Dispense Drug for IV orderable
     111 N PSOI,TYPE,VOL,ORY
     112 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL=""
     113 S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B")
     114 S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1)))
     115 D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY)
     116 Q +$G(ORY)
     117 ;
     118LIST(IFN) ; -- Displays list of ORCHECK(IFN) checks
     119 N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF
     120 S ORZ=0 F  S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0  D
     121 . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High
     122 . S ORI=0 F  S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0  D
     123 . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>>  "_X_OFF Q
     124 . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX)  ; wrap
     125 . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>>  ",1:"      ")_ORTX(ORJ)_OFF
     126 W !
     127 Q
     128 ;
     129CANCEL() ; -- Returns 1 or 0: Cancel order(s)?
     130 N X,Y,DIR,NUM
     131 S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA"
     132 S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ")
     133 S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order.  If you wish to override these order checks"
     134 S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks."
     135 D ^DIR
     136 Q +Y
     137 ;
     138REASON() ; -- Reason for overriding order checks
     139 ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q  ??
     140 N X,Y,DIR
     141 S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: "
     142 S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters"
     143 D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^"
     144 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMED.m

    r613 r623  
    1 ORCMED  ;SLC/MKB-Medication actions ;03/19/07
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243**;Dec 17, 1997;Build 242
    3 XFER    ; -- transfer to in/outpt meds
    4         N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR
    5         S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D  G XFQ ; lock pt chart
    6         . W !!,$C(7),$P(ORPTLK,U,2) H 2
    7         . S:'$D(VALMBCK) VALMBCK=""
    8         I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ
    9         D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X"
    10         S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD)
    11         S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D  Q:$G(OREVENT)="^"
    12         . W !!,$$CURRENT^OREVNT
    13         . S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q
    14         . S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1)
    15         I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ
    16         S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ
    17         I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location?
    18         S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
    19         S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0))
    20         S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
    21         D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3)
    22         S ORNMSP="PS" D DISPLAY^ORCHECK
    23         S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1
    24 XF1     F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR  I $D(ORQUIT),ORI<ORCNT Q:'$$CONT  ;if not last one, ask
    25         . K ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR
    26         . K ^TMP("PSJMR",$J),^TMP("ORWORD",$J),^TMP("ORSIG",$J)
    27         . S OLDIFN=+$P($G(^TMP("OR",$J,ORTAB,"IDX",NMBR)),U,4)
    28         . S ORDITM=$$ORDITEM^ORCACT(OLDIFN) D SUBHDR^ORCACT(ORDITM)
    29         . I '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR) W !,ORERR H 2 Q
    30         . S ORD=$P($G(^OR(100,OLDIFN,0)),U,5) Q:ORD'["101.41"  ;error msg?
    31         . S ORDIALOG=$S(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG)
    32         . S ORDG=+$P($G(^ORD(101.41,ORDIALOG,0)),U,5)
    33         . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(OLDIFN)
    34         . I ORDIALOG'=ORIVDLG D OUT:ORCAT="I",IN:ORCAT="O" ;convert data
    35         . K ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)
    36         . K ORDIALOG($$PTR^ORCD("OR GTX NOW"),1)
    37         . S ORLOG=+$E($$NOW^XLFDT,1,12),FIRST=1
    38 XF2     . D DIALOG^ORCDLG Q:$G(ORQUIT)&FIRST  K ORQUIT
    39         . D ACCEPT^ORCHECK(),DISPLAY^ORCDLG S X=$$OK^ORCDLG I X="^" S ORQUIT=1 Q
    40         . I X="E" K ORCHECK S FIRST=0 G XF2
    41         . I X="C" W !?10,"... order cancelled.",! Q
    42         . I X="P" D
    43         . . D EN^ORCSAVE W !?10,$S(ORIFN:"... order placed.",1:"ERROR"),!
    44         . . S:$G(ORIFN) ^TMP("ORNEW",$J,ORIFN,1)=""
    45         . . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^(ORDIALOG)=ORDIALOG M:$D(^TMP("ORWORD",$J)) ^TMP("ORECALL",$J,ORDIALOG)=^TMP("ORWORD",$J) ;save 1st values
    46 XFQ     D EXIT^ORCDPS1 ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4)
    47         K ^TMP("ORWORD",$J),^TMP("ORSIG",$J)
    48         D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
    49         Q
    50         ;
    51 IN      ; -- Kill extra values, Reset ID's/DD from Inpt dialog
    52         N P F P="START DATE/TIME","NOW" K ORDIALOG($$PTR(P),1)
    53         D DOSES("O")
    54         Q
    55         ;
    56 OUT     ; -- Kill extra values, Reset ID's/DD from Outpt dialog
    57         N P I '$O(ORDIALOG($$PTR("INSTRUCTIONS"),0)) D  ;old sig in comments
    58         . N WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORSIG",$J)
    59         . M ^TMP("ORSIG",$J)=^TMP("ORWORD",$J,WP,1)
    60         . K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP,1)
    61         F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1)
    62         I $G(ORDIALOG($$PTR("URGENCY"),1))=99 K ORDIALOG($$PTR("URGENCY"),1)
    63         D DOSES("I")
    64         Q
    65         ;
    66 DOSES(TYPE)         ; -- Convert doses to new TYPE, reset ID strings
    67         N PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR
    68         F I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG" K ORDIALOG($$PTR(I),1)
    69         S PSOI=+$P($G(^ORD(101.43,+$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2),ORMED=$P($G(^(0)),U)
    70         D DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP) I $G(ORDOSE(1))=-1 K ORDOSE
    71         S PROMPT=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")
    72         S DRUG=$$PTR("DISPENSE DRUG") D D1^ORCDPS2
    73         S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  D
    74         . K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X)
    75         . S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD
    76         . S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&")
    77         . S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD))
    78         . S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6)
    79         . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q
    80         . I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR
    81         Q
    82         ;
    83 CONT()  ; -- Want to continue processing orders?
    84         N X,Y,DIR
    85         S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES"
    86         S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option."
    87         D ^DIR
    88         Q +Y
    89         ;
    90 SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J)
    91         N ORTX,I,X,ORMAX S ORMAX=72
    92         S I=0 F  S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0  S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB
    93         S I=0 F  S I=$O(ORTX(I)) Q:I'>0  W !,$S(I=1:"(Sig: ",1:"      ")_ORTX(I)
    94         W ")"
    95         Q
    96         ;
    97 PTR(NAME)       ; -- Returns pointer to OR GTX NAME
    98         Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
    99         ;
    100 REFILLS ; -- Request a refill for med orders
    101         ;    ORNMBR = #,#,...,# of selected orders
    102         ;
    103         N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT
    104         I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ
    105         D FREEZE^ORCMENU S VALMBCK="R"
    106         S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ
    107         S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ
    108         S OROUT=$$ROUTING G:OROUT="^" RFQ
    109         F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR  Q:$D(ORQUIT)
    110         . S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4)
    111         . Q:'ORIFN  I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q
    112         . S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM)
    113         . I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q
    114         . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q
    115         . D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN)
    116         . W !?10,"... refill requested.",$$RETURN
    117 RFQ     Q
    118         ;
    119 RETURN()        ; -- press return to cont
    120         N X W !,"Press <return> to continue ..." R X:DTIME
    121         Q ""
    122         ;
    123 ROUTING()       ; -- Routing for refill
    124         N X,Y,DIR S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;"
    125         S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW")
    126         S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic"
    127         D ^DIR S:$D(DTOUT)!(X["^") Y="^"
    128         Q Y
    129         ;
    130 NW      ; -- Order New Medication from Meds tab
    131         ;    Requires ORDIALOG      = name of pkg dialog
    132         ;             OREVENT       = event, if delaying orders
    133         ;             OREVENT("TS") = treating spec, if admission or transfer
    134         N ORPTLK G:'$L($G(ORDIALOG)) NWQ
    135         S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
    136         D FREEZE^ORCMENU S VALMBCK="R"
    137         S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ
    138         I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ
    139         S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ
    140         D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J))
    141         K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R"
    142 NWQ     D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
    143         Q
     1ORCMED ;SLC/MKB-Medication actions ;4/2/02  16:45
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195**;Dec 17, 1997
     3XFER ; -- transfer to in/outpt meds
     4 N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR
     5 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D  G XFQ ; lock pt chart
     6 . W !!,$C(7),$P(ORPTLK,U,2) H 2
     7 . S:'$D(VALMBCK) VALMBCK=""
     8 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ
     9 D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X"
     10 S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD)
     11 S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D  Q:$G(OREVENT)="^"
     12 . W !!,$$CURRENT^OREVNT
     13 . S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q
     14 . S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1)
     15 I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ
     16 S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ
     17 I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location?
     18 S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
     19 S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0))
     20 S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
     21 D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3)
     22 S ORNMSP="PS" D DISPLAY^ORCHECK
     23 S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1
     24XF1 F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR  I $D(ORQUIT),ORI<ORCNT Q:'$$CONT  ;if not last one, ask
     25 . K ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR
     26 . K ^TMP("PSJMR",$J),^TMP("ORWORD",$J),^TMP("ORSIG",$J)
     27 . S OLDIFN=+$P($G(^TMP("OR",$J,ORTAB,"IDX",NMBR)),U,4)
     28 . S ORDITM=$$ORDITEM^ORCACT(OLDIFN) D SUBHDR^ORCACT(ORDITM)
     29 . I '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR) W !,ORERR H 2 Q
     30 . S ORD=$P($G(^OR(100,OLDIFN,0)),U,5) Q:ORD'["101.41"  ;error msg?
     31 . S ORDIALOG=$S(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG)
     32 . S ORDG=+$P($G(^ORD(101.41,ORDIALOG,0)),U,5)
     33 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(OLDIFN)
     34 . I ORDIALOG'=ORIVDLG D OUT:ORCAT="I",IN:ORCAT="O" ;convert data
     35 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)
     36 . K ORDIALOG($$PTR^ORCD("OR GTX NOW"),1)
     37 . S ORLOG=+$E($$NOW^XLFDT,1,12),FIRST=1
     38XF2 . D DIALOG^ORCDLG Q:$G(ORQUIT)&FIRST  K ORQUIT
     39 . D ACCEPT^ORCHECK(),DISPLAY^ORCDLG S X=$$OK^ORCDLG I X="^" S ORQUIT=1 Q
     40 . I X="E" K ORCHECK S FIRST=0 G XF2
     41 . I X="C" W !?10,"... order cancelled.",! Q
     42 . I X="P" D
     43 . . D EN^ORCSAVE W !?10,$S(ORIFN:"... order placed.",1:"ERROR"),!
     44 . . S:$G(ORIFN) ^TMP("ORNEW",$J,ORIFN,1)=""
     45 . . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^(ORDIALOG)=ORDIALOG M:$D(^TMP("ORWORD",$J)) ^TMP("ORECALL",$J,ORDIALOG)=^TMP("ORWORD",$J) ;save 1st values
     46XFQ D EXIT^ORCDPS1 ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4)
     47 K ^TMP("ORWORD",$J),^TMP("ORSIG",$J)
     48 D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
     49 Q
     50 ;
     51IN ; -- Kill extra values, Reset ID's/DD from Inpt dialog
     52 N P F P="START DATE/TIME","NOW" K ORDIALOG($$PTR(P),1)
     53 D DOSES("O")
     54 Q
     55 ;
     56OUT ; -- Kill extra values, Reset ID's/DD from Outpt dialog
     57 N P I '$O(ORDIALOG($$PTR("INSTRUCTIONS"),0)) D  ;old sig in comments
     58 . N WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORSIG",$J)
     59 . M ^TMP("ORSIG",$J)=^TMP("ORWORD",$J,WP,1)
     60 . K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP,1)
     61 F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1)
     62 I $G(ORDIALOG($$PTR("URGENCY"),1))=99 K ORDIALOG($$PTR("URGENCY"),1)
     63 D DOSES("I")
     64 Q
     65 ;
     66DOSES(TYPE)     ; -- Convert doses to new TYPE, reset ID strings
     67 N PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR
     68 F I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG" K ORDIALOG($$PTR(I),1)
     69 S PSOI=+$P($G(^ORD(101.43,+$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2),ORMED=$P($G(^(0)),U)
     70 D DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP) I $G(ORDOSE(1))=-1 K ORDOSE
     71 S PROMPT=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")
     72 S DRUG=$$PTR("DISPENSE DRUG") D D1^ORCDPS2
     73 S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  D
     74 . K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X)
     75 . S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD
     76 . S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&")
     77 . S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD))
     78 . S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6)
     79 . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q
     80 . I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR
     81 Q
     82 ;
     83CONT() ; -- Want to continue processing orders?
     84 N X,Y,DIR
     85 S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES"
     86 S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option."
     87 D ^DIR
     88 Q +Y
     89 ;
     90SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J)
     91 N ORTX,I,X,ORMAX S ORMAX=72
     92 S I=0 F  S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0  S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB
     93 S I=0 F  S I=$O(ORTX(I)) Q:I'>0  W !,$S(I=1:"(Sig: ",1:"      ")_ORTX(I)
     94 W ")"
     95 Q
     96 ;
     97PTR(NAME) ; -- Returns pointer to OR GTX NAME
     98 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     99 ;
     100REFILLS ; -- Request a refill for med orders
     101 ;    ORNMBR = #,#,...,# of selected orders
     102 ;
     103 N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT
     104 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ
     105 D FREEZE^ORCMENU S VALMBCK="R"
     106 S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ
     107 S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ
     108 S OROUT=$$ROUTING G:OROUT="^" RFQ
     109 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR  Q:$D(ORQUIT)
     110 . S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4)
     111 . Q:'ORIFN  I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q
     112 . S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM)
     113 . I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q
     114 . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q
     115 . D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN)
     116 . W !?10,"... refill requested.",$$RETURN
     117RFQ Q
     118 ;
     119RETURN() ; -- press return to cont
     120 N X W !,"Press <return> to continue ..." R X:DTIME
     121 Q ""
     122 ;
     123ROUTING() ; -- Routing for refill
     124 N X,Y,DIR S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;"
     125 S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW")
     126 S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic"
     127 D ^DIR S:$D(DTOUT)!(X["^") Y="^"
     128 Q Y
     129 ;
     130NW ; -- Order New Medication from Meds tab
     131 ;    Requires ORDIALOG      = name of pkg dialog
     132 ;             OREVENT       = event, if delaying orders
     133 ;             OREVENT("TS") = treating spec, if admission or transfer
     134 N ORPTLK G:'$L($G(ORDIALOG)) NWQ
     135 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
     136 D FREEZE^ORCMENU S VALMBCK="R"
     137 S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ
     138 I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ
     139 S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ
     140 D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J))
     141 K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R"
     142NWQ D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
     143 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT0.m

    r613 r623  
    1 ORCMEDT0        ;SLC/MKB-Dialog Utilities ;08/06/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243**;Dec 17, 1997;Build 242
    3 DIALOG(TYPE)    ; -- Get Dialog file entry
    4         N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
    5         S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ"
    6         S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41
    7         S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
    8         S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"")
    9 D0      S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ
    10         S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry
    11         I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0
    12         I TYPE="D" D  G:ORDLG="^" DQ ;new dialog
    13         . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE
    14         . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5)
    15         . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q
    16         . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^"
    17         I TYPE="Q" D  G DQ ;new quick order
    18         . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)"
    19         . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC
    20         . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q
    21         . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
    22         . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK
    23 D1      I $$COPY^ORCMEDIT(TYPE) D  ;copy an existing dialog?
    24         . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: "
    25         . D ^DIC Q:Y'>0  W !,"Copying ..."
    26         . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I)
    27         . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg
    28         . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text
    29         . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I)
    30         . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE
    31         . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK
    32 D2      I TYPE="D",$G(ORIT) D  ;stuff in default OI
    33         . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE
    34         . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D  Q:'DA  ;create OI prompt
    35         .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq#
    36         .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG
    37         .. D ^DIC Q:Y'>0  S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2)
    38         .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq#
    39         .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z
    40         .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)=""
    41         . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3)
    42         . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT
    43 DQ      Q ORDLG
    44         ;
    45 DEL(DA) ; -- delete bad entry in Order Dialog file
    46         N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK
    47         Q
    48         ;
    49 SAVE    ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG
    50         N PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD K ^ORD(101.41,ORQDLG,6)
    51         S (PROMPT,CNT)=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
    52         . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0))
    53         . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
    54         . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1
    55         . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST
    56         . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
    57         . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
    58         . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
    59         S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
    60         S INP=+$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
    61         S UD=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
    62         I +$G(ORDG)>0,ORDG=INP,UD>0 S ORDG=UD
    63         S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
    64         Q
    65         ;
    66 ITEM(Z) ; -- Select new item to add
    67         N X,Y,DIC,ORDDF,ORERR,I
    68         S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: "
    69         I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z
    70         S DIC("S")="I $P(^(0),U,4)'=""P"""
    71 IT1     D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y
    72         D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D  G IT1
    73         . W $C(7),!!,"An ancestor of this menu may not be added as an item!"
    74         . W !,ORERR S I=0 F  S I=$O(ORERR(I)) Q:I'>0  W !?18," =>"_ORERR(I)
    75         Q +Y
     1ORCMEDT0 ;SLC/MKB-Dialog Utilities ;04:11 PM  12 Feb 1999
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215**;Dec 17, 1997
     3DIALOG(TYPE) ; -- Get Dialog file entry
     4 N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
     5 S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ"
     6 S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41
     7 S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
     8 S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"")
     9D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ
     10 S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry
     11 I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0
     12 I TYPE="D" D  G:ORDLG="^" DQ ;new dialog
     13 . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE
     14 . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5)
     15 . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q
     16 . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^"
     17 I TYPE="Q" D  G DQ ;new quick order
     18 . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)"
     19 . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC
     20 . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q
     21 . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
     22 . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK
     23D1 I $$COPY^ORCMEDIT(TYPE) D  ;copy an existing dialog?
     24 . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: "
     25 . D ^DIC Q:Y'>0  W !,"Copying ..."
     26 . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I)
     27 . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg
     28 . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text
     29 . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I)
     30 . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE
     31 . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK
     32D2 I TYPE="D",$G(ORIT) D  ;stuff in default OI
     33 . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE
     34 . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D  Q:'DA  ;create OI prompt
     35 .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq#
     36 .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG
     37 .. D ^DIC Q:Y'>0  S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2)
     38 .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq#
     39 .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z
     40 .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)=""
     41 . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3)
     42 . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT
     43DQ Q ORDLG
     44 ;
     45DEL(DA) ; -- delete bad entry in Order Dialog file
     46 N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK
     47 Q
     48 ;
     49SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG
     50 N PROMPT,CNT,ITM,TYPE,INST,VALUE K ^ORD(101.41,ORQDLG,6)
     51 S (PROMPT,CNT)=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
     52 . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0))
     53 . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
     54 . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1
     55 . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST
     56 . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
     57 . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
     58 . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
     59 S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
     60 S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
     61 Q
     62 ;
     63ITEM(Z) ; -- Select new item to add
     64 N X,Y,DIC,ORDDF,ORERR,I
     65 S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: "
     66 I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z
     67 S DIC("S")="I $P(^(0),U,4)'=""P"""
     68IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y
     69 D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D  G IT1
     70 . W $C(7),!!,"An ancestor of this menu may not be added as an item!"
     71 . W !,ORERR S I=0 F  S I=$O(ORERR(I)) Q:I'>0  W !?18," =>"_ORERR(I)
     72 Q +Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT1.m

    r613 r623  
    1 ORCMEDT1        ;SLC/MKB-QO,Set editor ;02/25/08
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245,243**;Dec 17, 1997;Build 242
    3 OI      ; -- Enter/edit generic orderable items
    4         N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG
    5         F  S ORDG=$$DGRP Q:ORDG'>0  D  W !!
    6         . F  S D="S."_$P(ORDG,U,4) D   Q:Y'>0  S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110
    7         .. S DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110
    8         Q
    9         ;
    10 DGRP()  ; -- Returns sub-display group of Nursing or Other for generic OI
    11         N X,Y,DIC,ORGRP,ORDG,ORI
    12         F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP)
    13         S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))"
    14         S DIC("A")="Type of Orderable: " D ^DIC
    15         S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0))
    16         Q Y
    17         ;
    18 QUICK   ; -- Enter/edit quick order dialogs
    19         N ORQDLG,ORDG
    20         F  S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^"  D QCK0(ORQDLG) W !
    21         Q
    22 QCK0(ORQDLG)    ; -- edit quick order ORQDLG
    23         N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC
    24         Q:'$G(ORQDLG)  S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z"
    25         S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^")  ;deleted,^
    26         S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
    27         S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:""),DIE="^ORD(101.41,"
    28         D ^DIE G:$D(Y)!$D(DTOUT) QR  D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR
    29         I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)=""
    30         W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ
    31 Q1      D DIALOG^ORCDLG G:$G(ORQUIT) QQ
    32         D DISPLAY^ORCDLG S ACTION=$$OK G:ACTION="^" QQ
    33         D:ACTION="P" SAVE^ORCMEDT0,AUTO(ORQDLG) I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C"
    34 QQ      X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4)
    35 QR      S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
    36         I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified
    37         Q
    38         ;
    39 OK()    ; -- Ready to save?
    40         N X,Y,DIR S DIR(0)="SAM^P:PLACE;E:EDIT;C:CANCEL;",DIR("B")="PLACE"
    41         S DIR("A")="(P)lace, (E)dit, or (C)ancel this quick order? "
    42         S DIR("?")="Enter P to save this quick order, or E to change any of the displayed values; enter C to quit without saving these responses"
    43         D ^DIR S:$D(DTOUT) Y="^"
    44         Q Y
    45         ;
    46 SAVE    G SAVE^ORCMEDT0
    47         ;
    48 AUTO(DLG)       ; -- set AutoAccept flag for GUI
    49         N X,Y,DIR
    50         I $$VALQO^ORWDXM3(+DLG)=0 S $P(^ORD(101.41,+DLG,5),U,8)="" Q
    51         S DIR(0)="YA",DIR("A")="Auto-accept this order? "
    52         S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO")
    53         S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order."
    54         D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"")
    55         I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required.
    56         Q
    57         ;
    58 SET     ; -- Order Sets
    59         N ORSET,ORDG
    60         F  S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^"  D SET0(ORSET) W !
    61         Q
    62 SET0(ORSET)     ; -- edit order set ORSET
    63         N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET)
    64         S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^")  ;deleted,^
    65         S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET
    66         S DIE="^ORD(101.41," D ^DIE Q:$D(Y)  Q:'$G(DA)
    67 S1      I $O(^ORD(101.41,+ORSET,10,0)) D  Q:QUIT  ;Show existing components
    68         . W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0
    69         . S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case
    70         . F  S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0  D
    71         . . S DA=0 F  S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0  D
    72         . . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q
    73         . . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press <return> to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q
    74         . . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U)
    75 S2      S QUIT=0 F  D  Q:QUIT  W ! ;Enter/edit components
    76         . S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D"
    77         . S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2)
    78         . K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q
    79         . S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA)
    80         . I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK
    81         Q
    82         ;
    83 PROTOCOL        ; -- Convert additional protocols to dialogs
    84         N X,Y,DIC,ORERR
    85         F  S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0  D  W !
    86         . S ORP=+Y,ORM=$$MENU Q:ORM="^"  ; What about "^^"-jumping? (ORWARD)
    87         . W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q
    88         . W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR
    89         Q
    90 ONE(PITEM,ORADD,ERROR)  ; -- Convert single item protocol, add to menu(s)
    91         N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK
    92         I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry
    93         S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM)
    94         I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q
    95         Q:'$G(ORADD)  ;to add, may enter here with PITEM & DITEM defined
    96 ADD     S PMENU=0 F  S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0  D  W "."
    97         . S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU
    98         . S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS
    99         . S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0))
    100         . S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM  S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision
    101         . S DA=$$NEXT^ORCONVRT(DMENU)
    102         . S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"")
    103         . S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)=""
    104         . S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H
    105         Q
    106         ;
    107 FINDXUTL(MENU,ITEM)     ; -- Returns position of ITEM in MENU
    108         N XQORM,POS
    109         S XQORM=MENU_";ORD(101," D XREF^XQORM
    110         S POS=0 F  S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0  I $P(^(POS,0),U,2)=ITEM Q
    111         Q POS
    112         ;
    113 MENU()  ; -- Add converted item to menus?
    114         N X,Y,DIR S DIR(0)="YA"
    115         S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES"
    116         S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file"
    117         D ^DIR S:$D(DTOUT) Y="^"
    118         Q Y
    119 EXPLAIN ;Give reason why user can't set auto-accept to yes
    120         W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed."
    121         W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over.  If you wish to have"
    122         W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you."
    123         Q
     1ORCMEDT1 ;SLC/MKB-QO,Set editor ;11/6/01  13:33
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245**;Dec 17, 1997;Build 2
     3OI ; -- Enter/edit generic orderable items
     4 N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG
     5 F  S ORDG=$$DGRP Q:ORDG'>0  D  W !!
     6 . F  S D="S."_$P(ORDG,U,4) D   Q:Y'>0  S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110
     7 .. S DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110
     8 Q
     9 ;
     10DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI
     11 N X,Y,DIC,ORGRP,ORDG,ORI
     12 F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP)
     13 S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))"
     14 S DIC("A")="Type of Orderable: " D ^DIC
     15 S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0))
     16 Q Y
     17 ;
     18QUICK ; -- Enter/edit quick order dialogs
     19 N ORQDLG,ORDG
     20 F  S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^"  D QCK0(ORQDLG) W !
     21 Q
     22QCK0(ORQDLG) ; -- edit quick order ORQDLG
     23 N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC
     24 Q:'$G(ORQDLG)  S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z"
     25 S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^")  ;deleted,^
     26 S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
     27 S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:""),DIE="^ORD(101.41,"
     28 D ^DIE G:$D(Y)!$D(DTOUT) QR  D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR
     29 I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)=""
     30 W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ
     31Q1 D DIALOG^ORCDLG G:$G(ORQUIT) QQ
     32 D DISPLAY^ORCDLG S ACTION=$$OK G:ACTION="^" QQ
     33 D:ACTION="P" SAVE^ORCMEDT0,AUTO(ORQDLG) I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C"
     34QQ X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4)
     35QR S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
     36 I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified
     37 Q
     38 ;
     39OK() ; -- Ready to save?
     40 N X,Y,DIR S DIR(0)="SAM^P:PLACE;E:EDIT;C:CANCEL;",DIR("B")="PLACE"
     41 S DIR("A")="(P)lace, (E)dit, or (C)ancel this quick order? "
     42 S DIR("?")="Enter P to save this quick order, or E to change any of the displayed values; enter C to quit without saving these responses"
     43 D ^DIR S:$D(DTOUT) Y="^"
     44 Q Y
     45 ;
     46SAVE G SAVE^ORCMEDT0
     47 ;
     48AUTO(DLG) ; -- set AutoAccept flag for GUI
     49 N X,Y,DIR
     50 S DIR(0)="YA",DIR("A")="Auto-accept this order? "
     51 S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO")
     52 S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order."
     53 D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"")
     54 I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required.
     55 Q
     56 ;
     57SET ; -- Order Sets
     58 N ORSET,ORDG
     59 F  S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^"  D SET0(ORSET) W !
     60 Q
     61SET0(ORSET) ; -- edit order set ORSET
     62 N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET)
     63 S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^")  ;deleted,^
     64 S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET
     65 S DIE="^ORD(101.41," D ^DIE Q:$D(Y)  Q:'$G(DA)
     66S1 I $O(^ORD(101.41,+ORSET,10,0)) D  Q:QUIT  ;Show existing components
     67 . W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0
     68 . S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case
     69 . F  S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0  D
     70 . . S DA=0 F  S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0  D
     71 . . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q
     72 . . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press <return> to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q
     73 . . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U)
     74S2 S QUIT=0 F  D  Q:QUIT  W ! ;Enter/edit components
     75 . S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D"
     76 . S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2)
     77 . K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q
     78 . S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA)
     79 . I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK
     80 Q
     81 ;
     82PROTOCOL ; -- Convert additional protocols to dialogs
     83 N X,Y,DIC,ORERR
     84 F  S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0  D  W !
     85 . S ORP=+Y,ORM=$$MENU Q:ORM="^"  ; What about "^^"-jumping? (ORWARD)
     86 . W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q
     87 . W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR
     88 Q
     89ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s)
     90 N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK
     91 I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry
     92 S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM)
     93 I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q
     94 Q:'$G(ORADD)  ;to add, may enter here with PITEM & DITEM defined
     95ADD S PMENU=0 F  S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0  D  W "."
     96 . S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU
     97 . S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS
     98 . S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0))
     99 . S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM  S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision
     100 . S DA=$$NEXT^ORCONVRT(DMENU)
     101 . S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"")
     102 . S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)=""
     103 . S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H
     104 Q
     105 ;
     106FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU
     107 N XQORM,POS
     108 S XQORM=MENU_";ORD(101," D XREF^XQORM
     109 S POS=0 F  S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0  I $P(^(POS,0),U,2)=ITEM Q
     110 Q POS
     111 ;
     112MENU() ; -- Add converted item to menus?
     113 N X,Y,DIR S DIR(0)="YA"
     114 S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES"
     115 S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file"
     116 D ^DIR S:$D(DTOUT) Y="^"
     117 Q Y
     118EXPLAIN ;Give reason why user can't set auto-accept to yes
     119 W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed."
     120 W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over.  If you wish to have"
     121 W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you."
     122 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m

    r613 r623  
    1 ORCMEDT8        ;SLC/JM-QO, Generate quick order CRC ;10/18/07
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245,243**;Dec 17, 1997;Build 242
    3         Q
    4         ;
    5 UPDQNAME(ORIEN) ; Rename personal quick order name if needed
    6         N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL
    7         I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q
    8         S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1)
    9         I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q
    10         S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN)
    11         I OLDNAME'=NEWNAME D
    12         . S NEWNAME=$$ENSURNEW(NEWNAME)
    13         . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE
    14         Q
    15         ;
    16 ENSURNEW(NAME)  ; Ensures the name is a new entry
    17         N IDX,BASENAME,ABC,NEWNAME
    18         S NEWNAME=NAME
    19         S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name
    20         F  S IDX=$O(^ORD(101.41,"B",NEWNAME,0))  Q:'IDX  D
    21         . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z'
    22         . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97
    23         Q NEWNAME
    24 RAWCRC(ORIEN)   ; Get a raw CRC value to determine if a record has changed
    25         N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC
    26         S (RESULT,OLDCRC)=""
    27         I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ
    28         I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ
    29         D LOADRSP^ORWDX(.ORDATA,ORIEN)
    30         D PARSE
    31 RWQ     Q RESULT
    32         ;
    33         ; The following code attemps to duplicate the CRC calculated by the Delphi code
    34         ; in CPRS for quick orders.  It will not match all the time, since not all the
    35         ; data neded to make the determination is stored on the M side, but it does it's best.
    36         ;
    37 CRC4QCK(ORIEN)  ; Get CRC for a personal quick order
    38         N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF
    39         N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM
    40         S RESULT="",FORMID=0
    41         ; Must be personal quick order
    42         I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT
    43         I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT
    44         S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14)
    45         F  Q:(RESULT=OLDCRC)!(FORMID="")  D
    46         . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN)
    47         . ; First pass don't use any form id - get baseline CRC
    48         . I FORMID=1 D  Q:FORMID=""
    49         . . S FORMID=""
    50         . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q  ; Must have a valid display group
    51         . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q  ; Display group must have a valid default dialog
    52         . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q  ; Default dialog must have a valid windows form ID
    53         . . I (FORMID=130)!(FORMID=140) D
    54         . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135
    55         . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM)
    56         . I FORMID=0 S FORMID=1
    57         . E  D SORTDATA I FORMDATA="" S FORMID="" Q  ; Updates FORMID
    58         . D PARSE
    59 EXT     Q RESULT
    60         ;
    61 PARSE   ; Parse Data
    62         N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE
    63         S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE=""
    64         F  D GETLINE Q:DONE  D  Q:DONE
    65         . I ISMASTER D
    66         . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U
    67         . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
    68         . . S FIRST=1,P3=$P(LINE,U,3)
    69         . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1
    70         . . E  D
    71         . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0
    72         . . . E  S ADDCRLF=0,LK4SPACE=0
    73         . . F  D GETLINE Q:DONE!ISMASTER  D
    74         . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE
    75         . . . I CODE="t" D
    76         . . . . I FIRST S FIRST=0,OUTPUT=LINE
    77         . . . . E  D
    78         . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q
    79         . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT=""
    80         . . . . . E  D
    81         . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65
    82         . . . . . . E  S OUTPUT=" "
    83         . . . . . S OUTPUT=OUTPUT_LINE
    84         . . . . S LASTLINE=LINE
    85         . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
    86         . . . . I ADDCRLF S LASTIDX=IDX
    87         . . I ISMASTER,'DONE S LASTMSTR=1
    88         S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
    89         ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped
    90         I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D
    91         . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10)
    92         . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
    93         Q
    94         ;
    95 SORTDATA        ; Sorts data by fields according to FormID
    96         N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE
    97         S SUBFORM="",SUBFORM2=""
    98         S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
    99         I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
    100         S IN=0,OUT=0,END=1000000,IDX=0
    101         F  S IN=$O(ORDATA(IN)) Q:'+IN  D
    102         . S LINE=ORDATA(IN)
    103         . I $E(LINE)="~" D
    104         . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2)
    105         . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0
    106         . . I INDEX=0,SUBFORM'="" D
    107         . . . S INDEX=($F(FORMDATA,".ZZZ."))
    108         . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0
    109         . . I INDEX=0,SUBFORM2'="" D
    110         . . . S INDEX=($F(FORMDATA,".XXX."))
    111         . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0
    112         . . I INDEX=0 S OUT=END,END=END+1
    113         . . E  D
    114         . . . I SUBIDX>0 D  I 1
    115         . . . . S OUT=(INDEX-4)*250
    116         . . . . S SUBIDX=(SUBIDX-4)\4
    117         . . . . S OUT=OUT+SUBIDX+(NODE*20)
    118         . . . E  S OUT=(INDEX-4)*250
    119         . I IDX>0 D
    120         . . S DATA(OUT,IDX)=LINE
    121         . . S IDX=IDX+1
    122         K ORDATA
    123         S (IN,OUT,INDEX)=0
    124         F  S IN=$O(DATA(IN)) Q:'+IN  D
    125         . F  S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX  D
    126         . . S OUT=OUT+1
    127         . . S ORDATA(OUT)=DATA(IN,INDEX)
    128         S FORMID=$G(NEXTFORM(FORMID))
    129         Q
    130         ;
    131 GETLINE ;
    132         I LASTMSTR S LASTMSTR=0 Q
    133         S DATAIDX=$O(ORDATA(DATAIDX))
    134         S DONE=(DATAIDX="")
    135         I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~")
    136         Q
    137         ;
    138 FORMINFO(FORMINFO,IDINFO,NEXTFORM)      ; populates FORMINFO,IDINFO and NEXTFORM arrays
    139         N IDX,LINE,CODE,RTN,NEXT
    140         S IDX=1
    141         F  S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1  D
    142         . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999)
    143         . S FORMINFO(CODE)=LINE
    144         . I NEXT'="   " S NEXTFORM(CODE)=NEXT
    145         . S IDX=IDX+1
    146         S IDX=1
    147         F  S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1  D
    148         . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99)
    149         . S IDINFO(LINE)=CODE,IDX=IDX+1
    150         Q
    151         ;
    152 HASCODE(CODE)   ; scans data for code
    153         N RESULT,IDX,LINE S IDX="",RESULT=0
    154         F  S IDX=$O(ORDATA(IDX)) Q:IDX=""  D  Q:IDX=""
    155         . S LINE=ORDATA(IDX)
    156         . I $E(LINE)="~" D
    157         . . S LINE=$P(LINE,U,3)
    158         . . I LINE=CODE S RESULT=1,IDX=""
    159         Q RESULT
    160         ;
    161 SUBID   ; SubID codes are used to change the form ID depending on depending on data
    162         ; Data below is FormID;SubID.list of ID codes in order of use
    163         ; SubID's are used to change the FormID depending on data values.
    164         Q
    165 SUBID01 ; Generic Meds dialog
    166         N INPT,COMPLEX
    167         S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS")
    168         I INPT D  I 1
    169         . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX"))
    170         . E  S FORMID="INP"
    171         E  I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX"))
    172         Q
    173 SUBID02 ; IV Meds
    174         S SUBFORM=$G(FORMINFO("IVL"))
    175         Q
    176 SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side
    177         I '$$HASCODE("URGENCY") D
    178         . N X
    179         . S X=$O(ORDATA(999999),-1)+1
    180         . S ORDATA(X)="~0^1^URGENCY"
    181         Q
    182 SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26
    183         S SUBFORM=$G(FORMINFO("BBK"))
    184         S SUBFORM2=$G(FORMINFO("BBX"))
    185         Q
    186 SUBID05 ; Diet
    187         I FORMID="117" S SUBFORM=$G(FORMINFO("DLN"))
    188         I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL"))
    189         Q
    190 FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215)
    191         ;;Consult         ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.
    192         ;;                ;CS2;   ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.
    193         ;;Procedure       ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.
    194         ;;                ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV.
    195         ;;                ;PR3;   ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.
    196         ;;Diet            ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN.
    197         ;;                ;TBF;OPM;05.ZZZ.COM.CAN.
    198         ;;                ;OPM;   ;00.ORD.MEL.STT.STP.SCH.COM.DEL.
    199         ;;                ;DLN;   ;00.ORD.
    200         ;;                ;TBL;   ;00.ORD.STR.INS.
    201         ;;Lab             ;120;   ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY.
    202         ;;Blood Bank      ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.LAB.
    203         ;;                ;BB2;   ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX.
    204         ;;                ;BBK;   ;00.ORD.QTY.MDF.SPC.
    205         ;;                ;BBX;   ;00.RES.
    206         ;;Inpatient Meds  ;130;   ;00.ORD.DRG.INS.ROU.SCH.URG.COM.SCT.ADM
    207         ;;Generic Meds    ;135;   ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.
    208         ;;                ;INP;   ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG.
    209         ;;                ;OPX;   ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.
    210         ;;                ;INX;   ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG.
    211         ;;                ;MDX;   ;00.INS.DOS.ROU.SCH.DAY.CNJ.
    212         ;;Outpatient Meds ;140;   ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0.
    213         ;;Non-VA Meds     ;145;   ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG.
    214         ;;Radiology       ;160;   ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC.
    215         ;;IV Meds         ;180;   ;02.ZZZ.RAT.URG.DAY.COM.SCH.TYP.ADM
    216         ;;                ;IVL;   ;00.ORD.VOL.ADD.STR.UNT.
    217         ;;
    218 IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME
    219         ;;ADD;ADDITIVE
    220         ;;ADM:ADMIN
    221         ;;CAN;CANCEL
    222         ;;CLS;CLASS
    223         ;;COD;CODE
    224         ;;COL;COLLECT
    225         ;;COM;COMMENT
    226         ;;CNJ;CONJ
    227         ;;CON;CONTRACT
    228         ;;DTE;DATETIME
    229         ;;DAY;DAYS
    230         ;;DEL;DELIVERY
    231         ;;DOS;DOSE
    232         ;;DRG;DRUG
    233         ;;IML;IMLOC
    234         ;;INS;INSTR
    235         ;;ISO;ISOLATION
    236         ;;LAB;LAB
    237         ;;LOC;LOCATION
    238         ;;MEL;MEAL
    239         ;;MSC;MISC
    240         ;;MOD;MODE
    241         ;;MDF;MODIFIER
    242         ;;NAM;NAME
    243         ;;NOW;NOW
    244         ;;ORD;ORDERABLE
    245         ;;PI0;PI
    246         ;;PCK;PICKUP
    247         ;;PLA;PLACE
    248         ;;PRG;PREGNANT
    249         ;;PRE;PREOP
    250         ;;PRV;PROVIDER
    251         ;;QTY;QTY
    252         ;;RAT;RATE
    253         ;;REA;REASON
    254         ;;REF;REFILLS
    255         ;;RSH:RESEARCH
    256         ;;RES;RESULTS
    257         ;;ROU;ROUTE
    258         ;;SAM;SAMPLE
    259         ;;SC0;SC
    260         ;;SCH;SCHEDULE
    261         ;;SCT:SCHTYPE
    262         ;;SER;SERVICE
    263         ;;SIG;SIG
    264         ;;SPE;SPECIMEN
    265         ;;SPC;SPECSTS
    266         ;;STT;START
    267         ;;STA;STATEMENTS
    268         ;;STP;STOP
    269         ;;STR;STRENGTH
    270         ;;SUP;SUPPLY
    271         ;;TIM;TIME
    272         ;;TYP:TYPE
    273         ;;UNT;UNITS
    274         ;;URG;URGENCY
    275         ;;VIS;VISITSTR
    276         ;;VOL;VOLUME
    277         ;;XFU;XFUSION
    278         ;;YN0;YN
    279         ;;XXX;XXX
    280         ;;ZZZ;ZZZ
    281         ;;             
     1ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;3/3/06
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245**;Dec 17, 1997;Build 2
     3 Q
     4 ;
     5UPDQNAME(ORIEN) ; Rename personal quick order name if needed
     6 N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL
     7 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q
     8 S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1)
     9 I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q
     10 S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN)
     11 I OLDNAME'=NEWNAME D
     12 . S NEWNAME=$$ENSURNEW(NEWNAME)
     13 . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE
     14 Q
     15 ;
     16ENSURNEW(NAME) ; Ensures the name is a new entry
     17 N IDX,BASENAME,ABC,NEWNAME
     18 S NEWNAME=NAME
     19 S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name
     20 F  S IDX=$O(^ORD(101.41,"B",NEWNAME,0))  Q:'IDX  D
     21 . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z'
     22 . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97
     23 Q NEWNAME
     24RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed
     25 N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC
     26 S (RESULT,OLDCRC)=""
     27 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ
     28 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ
     29 D LOADRSP^ORWDX(.ORDATA,ORIEN)
     30 D PARSE
     31RWQ Q RESULT
     32 ;
     33 ; The following code attemps to duplicate the CRC calculated by the Delphi code
     34 ; in CPRS for quick orders.  It will not match all the time, since not all the
     35 ; data neded to make the determination is stored on the M side, but it does it's best.
     36 ;
     37CRC4QCK(ORIEN) ; Get CRC for a personal quick order
     38 N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF
     39 N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM
     40 S RESULT="",FORMID=0
     41 ; Must be personal quick order
     42 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT
     43 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT
     44 S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14)
     45 F  Q:(RESULT=OLDCRC)!(FORMID="")  D
     46 . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN)
     47 . ; First pass don't use any form id - get baseline CRC
     48 . I FORMID=1 D  Q:FORMID=""
     49 . . S FORMID=""
     50 . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q  ; Must have a valid display group
     51 . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q  ; Display group must have a valid default dialog
     52 . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q  ; Default dialog must have a valid windows form ID
     53 . . I (FORMID=130)!(FORMID=140) D
     54 . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135
     55 . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM)
     56 . I FORMID=0 S FORMID=1
     57 . E  D SORTDATA I FORMDATA="" S FORMID="" Q  ; Updates FORMID
     58 . D PARSE
     59EXT Q RESULT
     60 ;
     61PARSE ; Parse Data
     62 N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE
     63 S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE=""
     64 F  D GETLINE Q:DONE  D  Q:DONE
     65 . I ISMASTER D
     66 . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U
     67 . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
     68 . . S FIRST=1,P3=$P(LINE,U,3)
     69 . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1
     70 . . E  D
     71 . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0
     72 . . . E  S ADDCRLF=0,LK4SPACE=0
     73 . . F  D GETLINE Q:DONE!ISMASTER  D
     74 . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE
     75 . . . I CODE="t" D
     76 . . . . I FIRST S FIRST=0,OUTPUT=LINE
     77 . . . . E  D
     78 . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q
     79 . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT=""
     80 . . . . . E  D
     81 . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65
     82 . . . . . . E  S OUTPUT=" "
     83 . . . . . S OUTPUT=OUTPUT_LINE
     84 . . . . S LASTLINE=LINE
     85 . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
     86 . . . . I ADDCRLF S LASTIDX=IDX
     87 . . I ISMASTER,'DONE S LASTMSTR=1
     88 S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
     89 ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped
     90 I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D
     91 . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10)
     92 . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
     93 Q
     94 ;
     95SORTDATA ; Sorts data by fields according to FormID
     96 N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE
     97 S SUBFORM="",SUBFORM2=""
     98 S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
     99 I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
     100 S IN=0,OUT=0,END=1000000,IDX=0
     101 F  S IN=$O(ORDATA(IN)) Q:'+IN  D
     102 . S LINE=ORDATA(IN)
     103 . I $E(LINE)="~" D
     104 . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2)
     105 . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0
     106 . . I INDEX=0,SUBFORM'="" D
     107 . . . S INDEX=($F(FORMDATA,".ZZZ."))
     108 . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0
     109 . . I INDEX=0,SUBFORM2'="" D
     110 . . . S INDEX=($F(FORMDATA,".XXX."))
     111 . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0
     112 . . I INDEX=0 S OUT=END,END=END+1
     113 . . E  D
     114 . . . I SUBIDX>0 D  I 1
     115 . . . . S OUT=(INDEX-4)*250
     116 . . . . S SUBIDX=(SUBIDX-4)\4
     117 . . . . S OUT=OUT+SUBIDX+(NODE*20)
     118 . . . E  S OUT=(INDEX-4)*250
     119 . I IDX>0 D
     120 . . S DATA(OUT,IDX)=LINE
     121 . . S IDX=IDX+1
     122 K ORDATA
     123 S (IN,OUT,INDEX)=0
     124 F  S IN=$O(DATA(IN)) Q:'+IN  D
     125 . F  S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX  D
     126 . . S OUT=OUT+1
     127 . . S ORDATA(OUT)=DATA(IN,INDEX)
     128 S FORMID=$G(NEXTFORM(FORMID))
     129 Q
     130 ;
     131GETLINE ;
     132 I LASTMSTR S LASTMSTR=0 Q
     133 S DATAIDX=$O(ORDATA(DATAIDX))
     134 S DONE=(DATAIDX="")
     135 I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~")
     136 Q
     137 ;
     138FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays
     139 N IDX,LINE,CODE,RTN,NEXT
     140 S IDX=1
     141 F  S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1  D
     142 . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999)
     143 . S FORMINFO(CODE)=LINE
     144 . I NEXT'="   " S NEXTFORM(CODE)=NEXT
     145 . S IDX=IDX+1
     146 S IDX=1
     147 F  S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1  D
     148 . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99)
     149 . S IDINFO(LINE)=CODE,IDX=IDX+1
     150 Q
     151 ;
     152HASCODE(CODE) ; scans data for code
     153 N RESULT,IDX,LINE S IDX="",RESULT=0
     154 F  S IDX=$O(ORDATA(IDX)) Q:IDX=""  D  Q:IDX=""
     155 . S LINE=ORDATA(IDX)
     156 . I $E(LINE)="~" D
     157 . . S LINE=$P(LINE,U,3)
     158 . . I LINE=CODE S RESULT=1,IDX=""
     159 Q RESULT
     160 ;
     161SUBID ; SubID codes are used to change the form ID depending on depending on data
     162 ; Data below is FormID;SubID.list of ID codes in order of use
     163 ; SubID's are used to change the FormID depending on data values.
     164 Q
     165SUBID01 ; Generic Meds dialog
     166 N INPT,COMPLEX
     167 S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS")
     168 I INPT D  I 1
     169 . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX"))
     170 . E  S FORMID="INP"
     171 E  I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX"))
     172 Q
     173SUBID02 ; IV Meds
     174 S SUBFORM=$G(FORMINFO("IVL"))
     175 Q
     176SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side
     177 I '$$HASCODE("URGENCY") D
     178 . N X
     179 . S X=$O(ORDATA(999999),-1)+1
     180 . S ORDATA(X)="~0^1^URGENCY"
     181 Q
     182SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26
     183 S SUBFORM=$G(FORMINFO("BBK"))
     184 S SUBFORM2=$G(FORMINFO("BBX"))
     185 Q
     186SUBID05 ; Diet
     187 I FORMID="117" S SUBFORM=$G(FORMINFO("DLN"))
     188 I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL"))
     189 Q
     190FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215)
     191 ;;Consult         ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.
     192 ;;                ;CS2;   ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.
     193 ;;Procedure       ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.
     194 ;;                ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV.
     195 ;;                ;PR3;   ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.
     196 ;;Diet            ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN.
     197 ;;                ;TBF;OPM;05.ZZZ.COM.CAN.
     198 ;;                ;OPM;   ;00.ORD.MEL.STT.STP.SCH.COM.DEL.
     199 ;;                ;DLN;   ;00.ORD.
     200 ;;                ;TBL;   ;00.ORD.STR.INS.
     201 ;;Lab             ;120;   ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY.
     202 ;;Blood Bank      ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.
     203 ;;                ;BB2;   ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX.
     204 ;;                ;BBK;   ;00.ORD.QTY.MDF.SPC.
     205 ;;                ;BBX;   ;00.RES.
     206 ;;Inpatient Meds  ;130;   ;00.ORD.DRG.INS.ROU.SCH.URG.COM.
     207 ;;Generic Meds    ;135;   ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.
     208 ;;                ;INP;   ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG.
     209 ;;                ;OPX;   ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.
     210 ;;                ;INX;   ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG.
     211 ;;                ;MDX;   ;00.INS.DOS.ROU.SCH.DAY.CNJ.
     212 ;;Outpatient Meds ;140;   ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0.
     213 ;;Non-VA Meds     ;145;   ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG.
     214 ;;Radiology       ;160;   ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC.
     215 ;;IV Meds         ;180;   ;02.ZZZ.RAT.URG.DAY.COM.SCH.
     216 ;;                ;IVL;   ;00.ORD.VOL.ADD.STR.UNT.
     217 ;;
     218IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME
     219 ;;ADD;ADDITIVE
     220 ;;CAN;CANCEL
     221 ;;CLS;CLASS
     222 ;;COD;CODE
     223 ;;COL;COLLECT
     224 ;;COM;COMMENT
     225 ;;CNJ;CONJ
     226 ;;CON;CONTRACT
     227 ;;DTE;DATETIME
     228 ;;DAY;DAYS
     229 ;;DEL;DELIVERY
     230 ;;DOS;DOSE
     231 ;;DRG;DRUG
     232 ;;IML;IMLOC
     233 ;;INS;INSTR
     234 ;;ISO;ISOLATION
     235 ;;LOC;LOCATION
     236 ;;MEL;MEAL
     237 ;;MSC;MISC
     238 ;;MOD;MODE
     239 ;;MDF;MODIFIER
     240 ;;NAM;NAME
     241 ;;NOW;NOW
     242 ;;ORD;ORDERABLE
     243 ;;PI0;PI
     244 ;;PCK;PICKUP
     245 ;;PLA;PLACE
     246 ;;PRG;PREGNANT
     247 ;;PRE;PREOP
     248 ;;PRV;PROVIDER
     249 ;;QTY;QTY
     250 ;;RAT;RATE
     251 ;;REA;REASON
     252 ;;REF;REFILLS
     253 ;;RSH:RESEARCH
     254 ;;RES;RESULTS
     255 ;;ROU;ROUTE
     256 ;;SAM;SAMPLE
     257 ;;SC0;SC
     258 ;;SCH;SCHEDULE
     259 ;;SER;SERVICE
     260 ;;SIG;SIG
     261 ;;SPE;SPECIMEN
     262 ;;SPC;SPECSTS
     263 ;;STT;START
     264 ;;STA;STATEMENTS
     265 ;;STP;STOP
     266 ;;STR;STRENGTH
     267 ;;SUP;SUPPLY
     268 ;;TIM;TIME
     269 ;;UNT;UNITS
     270 ;;URG;URGENCY
     271 ;;VIS;VISITSTR
     272 ;;VOL;VOLUME
     273 ;;XFU;XFUSION
     274 ;;YN0;YN
     275 ;;XXX;XXX
     276 ;;ZZZ;ZZZ
     277 ;;             

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m

    r613 r623  
    1 ORCSAVE ;SLC/MKB/JDL-Save ; 7/24/07 9:54am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243**;Dec 17, 1997;Build 242
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG)      ; -- New order
    5         ; Returns ORIFN = [new] order number, if created/saved
    6         D EN
    7         Q
    8         ;
    9 XX      ; -- save new/unreleased edited order into Orders file
    10         ;    Requires: ORDIALOG() = array of dialog values
    11         ;              ORIFN      = IFN of original order that was edited
    12         ; 
    13         N OLDIFN S ORIFN=+ORIFN,OLDIFN=0
    14         I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed
    15         D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1
    16         I $G(OLDIFN) D  ;save links between orders
    17         . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1
    18         . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
    19         I $D(^OR(100,+OLDIFN,0)) D
    20         . Q:'$G(OREVTDF)
    21         . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN
    22         . S (OLDEVT,OLDSTS,LSTACT)=0
    23         . S NOW=$$NOW^XLFDT
    24         . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3)
    25         . ; Active status = 6 from #100.01
    26         . I (OLDEVT>0),OLDSTS=6 D
    27         . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT
    28         . . S $P(^OR(100,+ORIFN,3),U,3)=11
    29         . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7)
    30         . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D
    31         . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11
    32         . . . S PATID=$P(^OR(100,+ORIFN,0),U,2)
    33         . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U)
    34         . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""
    35         Q
    36         ;
    37 RN      ; -- save new/unreleased renewal order into Orders file
    38         ;    Requires: ORDIALOG() = array of new dialog values
    39         ;              ORIFN      = IFN of original order that was renewed
    40         ;
    41         N OLDIFN S OLDIFN=+ORIFN K ORIFN
    42         D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1
    43         S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2
    44         S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
    45         Q
    46         ;
    47 EN      ; -- save new/unreleased order in ORDIALOG() into Orders file
    48         ;    Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]
    49         ;    If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC
    50         ;     (else use values from ORDIALOG and current state)
    51         ;
    52         N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE
    53         Q:'$G(ORVP)  Q:'$G(ORDIALOG)  Q:'$D(^ORD(101.41,+ORDIALOG,0))
    54         S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6)
    55         S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O"))
    56         S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7))
    57         I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order
    58         S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5))
    59         I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195
    60         E  S LOC=$G(ORL),TRSPEC=$G(ORTS)
    61         S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0)
    62         S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)
    63         S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
    64         S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN
    65 EN1     S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT)
    66         S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE
    67         S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)=""
    68         S ^OR(100,"AF",LOG,ORIFN,1)=""
    69         S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""
    70         S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""
    71         S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""
    72         S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""
    73 EN2     S ORIFN=+ORIFN D RESPONSE ; save responses
    74         I $P(^OR(100,ORIFN,0),"^",5) D  ;Copy orders PKI fix
    75         . N OI
    76         . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI
    77         . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
    78         . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))
    79         . I $E($G(ORY))=2 S ORDEA=ORY
    80         K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text
    81         S NODE=$G(^OR(100,ORIFN,0)) D  S ^OR(100,ORIFN,0)=NODE
    82         . S $P(NODE,U,4)=$G(ORNP) ; COST?
    83         . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0))
    84         . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value
    85         . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0))
    86         . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X
    87         S $P(^OR(100,ORIFN,3),U)=NOW
    88         K ^OR(100,ORIFN,9) I $G(ORCHECK) D  ; save order checks
    89         . S (CNT,CDL)=0 F  S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0  S I=0 D
    90         . . F  S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0  S X=ORCHECK("NEW",CDL,I) D
    91         . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)=""
    92         . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245)
    93         . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
    94         K ORDEA
    95 ENQ     Q
    96         ;
    97 NEXTIFN()       ; -- Returns next available ORIFN
    98         N I,HDR,LAST,TOTAL,DA
    99         F I=1:1:10 L +^OR(100,0):1 Q:$T  H 2
    100         I '$T Q "^"
    101         S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1)
    102         S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0))
    103         S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
    104         S ^OR(100,0)=HDR L -^OR(100,0)
    105         Q DA
    106         ;
    107 RESPONSE        ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)
    108         N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X
    109         S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5)
    110         S (PROMPT,CNT)=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
    111         . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
    112         . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
    113         . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
    114         . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE=""  S CNT=CNT+1
    115         . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
    116         . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
    117         . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0
    118         . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE
    119         . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root
    120         S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT
    121 R1      ; [Reset] Orderables
    122         I $D(^OR(100,ORIFN,.1)) S I=0 F  S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0  S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref
    123         K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D
    124         . S (I,CNT)=0
    125         . F  S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D
    126         . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X
    127         . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)=""
    128         . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""
    129         . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT
    130         Q
    131         ;
    132 RESUME(IFN)     ; -- add Response nodes for RESUME tray service
    133         ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1
    134         ;
    135         N X,Y,DA,DIC
    136         S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT
    137         S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2)
    138         D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1
    139         Q
    140         ;
    141 PROVIDER(ORDER,PROV)    ; -- Change PROVider assigned to ORDER
    142         Q:'$G(ORDER)  Q:'$G(PROV)
    143         N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1
    144         S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV
    145         S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV
    146         Q
    147         ;
    148 ACTION(CODE,DA,PROV,REASON,WHEN,WHO)    ; -- save new action
    149         N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA
    150         Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0
    151         S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
    152         S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
    153         S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0))
    154         S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr
    155         S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4)
    156         S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D
    157         . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11  Q:$P(X,U,4)'=2
    158         . S NEXT=LAST I PAT,$P(X,U) D  ; kill old xref entries
    159         . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT)
    160         . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT)
    161         S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1
    162         S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)=""
    163         S ^OR(100,"AF",WHEN,DA,NEXT)=""
    164         I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
    165         I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
    166         I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
    167         S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON
    168         S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR
    169         Q NEXT
    170         ;
    171 SET(DLG)        ; -- Create new parent for order set ORDIALOG
    172         ; Returns ORPIFN = ifn of new parent order for set
    173         ;
    174         Q:'$G(ORVP)  Q:'$G(DLG)  N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X
    175         S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0=""  S ORPIFN=$$NEXTIFN Q:'ORPIFN
    176         S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12))
    177         I $G(OREVENT) S ORLOC="",TRSPEC=""
    178         S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6)
    179         S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)=""
    180         S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""
    181         S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""
    182         ; AEVNT ??
    183         S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text
    184         Q
     1ORCSAVE ;SLC/MKB/JDL-Save ;9/13/04  14:05
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195**;Dec 17, 1997
     3NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order
     4 ; Returns ORIFN = [new] order number, if created/saved
     5 D EN
     6 Q
     7 ;
     8XX ; -- save new/unreleased edited order into Orders file
     9 ;    Requires: ORDIALOG() = array of dialog values
     10 ;              ORIFN      = IFN of original order that was edited
     11 ; 
     12 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0
     13 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed
     14 D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1
     15 I $G(OLDIFN) D  ;save links between orders
     16 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1
     17 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
     18 I $D(^OR(100,+OLDIFN,0)) D
     19 . Q:'$G(OREVTDF)
     20 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN
     21 . S (OLDEVT,OLDSTS,LSTACT)=0
     22 . S NOW=$$NOW^XLFDT
     23 . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3)
     24 . ; Active status = 6 from #100.01
     25 . I (OLDEVT>0),OLDSTS=6 D
     26 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT
     27 . . S $P(^OR(100,+ORIFN,3),U,3)=11
     28 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7)
     29 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D
     30 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11
     31 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2)
     32 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U)
     33 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""
     34 Q
     35 ;
     36RN ; -- save new/unreleased renewal order into Orders file
     37 ;    Requires: ORDIALOG() = array of new dialog values
     38 ;              ORIFN      = IFN of original order that was renewed
     39 ;
     40 N OLDIFN S OLDIFN=+ORIFN K ORIFN
     41 D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1
     42 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2
     43 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
     44 Q
     45 ;
     46EN ; -- save new/unreleased order in ORDIALOG() into Orders file
     47 ;    Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]
     48 ;    If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC
     49 ;     (else use values from ORDIALOG and current state)
     50 ;
     51 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE
     52 Q:'$G(ORVP)  Q:'$G(ORDIALOG)  Q:'$D(^ORD(101.41,+ORDIALOG,0))
     53 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6)
     54 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O"))
     55 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7))
     56 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order
     57 S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5))
     58 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195
     59 E  S LOC=$G(ORL),TRSPEC=$G(ORTS)
     60 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0)
     61 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)
     62 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
     63 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN
     64EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT)
     65 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE
     66 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)=""
     67 S ^OR(100,"AF",LOG,ORIFN,1)=""
     68 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""
     69 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""
     70 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""
     71 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""
     72EN2 S ORIFN=+ORIFN D RESPONSE ; save responses
     73 I $P(^OR(100,ORIFN,0),"^",5) D  ;Copy orders PKI fix
     74 . N OI
     75 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI
     76 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
     77 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))
     78 . I $E($G(ORY))=2 S ORDEA=ORY
     79 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text
     80 S NODE=$G(^OR(100,ORIFN,0)) D  S ^OR(100,ORIFN,0)=NODE
     81 . S $P(NODE,U,4)=$G(ORNP) ; COST?
     82 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0))
     83 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value
     84 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0))
     85 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X
     86 S $P(^OR(100,ORIFN,3),U)=NOW
     87 K ^OR(100,ORIFN,9) I $G(ORCHECK) D  ; save order checks
     88 . S (CNT,CDL)=0 F  S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0  S I=0 D
     89 . . F  S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0  S X=ORCHECK("NEW",CDL,I) D
     90 . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)=""
     91 . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245)
     92 . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
     93 K ORDEA
     94ENQ Q
     95 ;
     96NEXTIFN() ; -- Returns next available ORIFN
     97 N I,HDR,LAST,TOTAL,DA
     98 F I=1:1:10 L +^OR(100,0):1 Q:$T  H 2
     99 I '$T Q "^"
     100 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1)
     101 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0))
     102 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
     103 S ^OR(100,0)=HDR L -^OR(100,0)
     104 Q DA
     105 ;
     106RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)
     107 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X
     108 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5)
     109 S (PROMPT,CNT)=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
     110 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
     111 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
     112 . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
     113 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE=""  S CNT=CNT+1
     114 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
     115 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
     116 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE
     117 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root
     118 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT
     119R1 ; [Reset] Orderables
     120 I $D(^OR(100,ORIFN,.1)) S I=0 F  S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0  S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref
     121 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D
     122 . S (I,CNT)=0
     123 . F  S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D
     124 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X
     125 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)=""
     126 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""
     127 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT
     128 Q
     129 ;
     130RESUME(IFN) ; -- add Response nodes for RESUME tray service
     131 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1
     132 ;
     133 N X,Y,DA,DIC
     134 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT
     135 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2)
     136 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1
     137 Q
     138 ;
     139PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER
     140 Q:'$G(ORDER)  Q:'$G(PROV)
     141 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1
     142 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV
     143 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV
     144 Q
     145 ;
     146ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action
     147 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA
     148 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0
     149 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
     150 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
     151 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0))
     152 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr
     153 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4)
     154 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D
     155 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11  Q:$P(X,U,4)'=2
     156 . S NEXT=LAST I PAT,$P(X,U) D  ; kill old xref entries
     157 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT)
     158 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT)
     159 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1
     160 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)=""
     161 S ^OR(100,"AF",WHEN,DA,NEXT)=""
     162 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
     163 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
     164 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
     165 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON
     166 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR
     167 Q NEXT
     168 ;
     169SET(DLG) ; -- Create new parent for order set ORDIALOG
     170 ; Returns ORPIFN = ifn of new parent order for set
     171 ;
     172 Q:'$G(ORVP)  Q:'$G(DLG)  N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X
     173 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0=""  S ORPIFN=$$NEXTIFN Q:'ORPIFN
     174 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12))
     175 I $G(OREVENT) S ORLOC="",TRSPEC=""
     176 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6)
     177 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)=""
     178 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""
     179 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""
     180 ; AEVNT ??
     181 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text
     182 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE1.m

    r613 r623  
    1 ORCSAVE1        ; SLC/MKB - Save Order Text ;02/22/07
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**92,132,141,163,187,223,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; ^ORD(101.41,+ORDIALOG,10,ITM,2)=Seq#^Format^Omit^Lead Text^Trail Text
    5         ; ^ORD(101.41,+ORDIALOG,10,"ATXT",Seq#,ITM)=""
    6         ;
    7 ORDTEXT(ORDER)  ; -- Build and save order text from ORDIALOG() into ORDER
    8         N ORTX,I,IFN,ACT,ORSET
    9         D ORTX(240) Q:'$G(ORTX)
    10         S IFN=+ORDER,ACT=+$P(ORDER,";",2) S:ACT'>0 ACT=1
    11         F I=1:1:ORTX S ^OR(100,IFN,8,ACT,.1,I,0)=ORTX(I)
    12         S ^OR(100,IFN,8,ACT,.1,0)=U_U_ORTX_U_ORTX_U_DT_U
    13         I $E($G(ORDEA))=2 D  ;PKI Drug Schedule - in future may allow 2-5
    14         . S ORSET=0
    15         . D DIGTEXT(IFN,ORDEA)
    16         . F I=1:1:ORSET S ^OR(100,IFN,8,ACT,.2,I,0)=ORSET(I)
    17         . I ORSET>0 S ^OR(100,IFN,8,ACT,.2,0)=U_U_ORSET_U_ORSET_U_DT_U
    18         Q
    19         ;
    20 ORTX(WIDTH)     ; -- May enter here to return order text in ORTX()
    21         N ORP,SEQ,ITEM,ORMAX,IVIEN,IVITEM,IVTYPE,RATE
    22         K ORTX S ORMAX=$S(+$G(WIDTH):WIDTH,1:240)
    23         D EXT ; get external form of values
    24         S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ)) Q:SEQ'>0  D
    25         . S ITEM=0 F  S ITEM=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ,ITEM)) Q:ITEM'>0  D TEXT(ITEM)
    26         Q
    27         ;
    28 TEXT(DA)        ; -- Includes text of item DA
    29         Q:$P(^ORD(101.41,ORDIALOG,10,DA,0),U,11)  Q:'$O(ORP(DA,0))
    30         N NEWLN,INST,TYPE,PTR,CHSEQ,CHILD,ORI,X,Y
    31         S:'$G(ORTX) ORTX=1,ORTX(1)=""
    32         S NEWLN=+$P(ORP(DA),U,4),INST=$O(ORP(DA,0)),Y=""
    33         I NEWLN,$L(ORTX(ORTX)) S ORTX=ORTX+1,ORTX(ORTX)="",Y=" "
    34         S X=$$GETXT($P(ORP(DA),U,2)) I $L(X) S X=Y_X,Y="" D TXT^ORCHTAB ;lead tx
    35         S PTR=+ORP(DA),TYPE=$E(ORDIALOG(PTR,0))
    36 TXT1    I TYPE'="W" S X=Y_ORP(DA,INST),Y="" D TXT^ORCHTAB
    37         I TYPE="W" S ORI=0 F  S ORI=$O(ORP(DA,INST,ORI)) Q:ORI'>0  D  S Y=""
    38         . S Y=$S(Y=" ":" ",$P(ORP(DA),U,5):" ",1:"") ;new line, or as stored
    39         . S X=Y_ORP(DA,INST,ORI,0),Y=""
    40         . I $E(X)'=" " D TXT^ORCHTAB Q  ; wrap
    41         . S:$L(ORTX(ORTX)) ORTX=ORTX+1,ORTX(ORTX)="" ; force new line
    42         . I X?1." " S ORTX(ORTX)=" ",ORTX=ORTX+1,ORTX(ORTX)="" ; blank line
    43         . E  D TXT^ORCHTAB
    44         D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PTR)) CHILD(PTR)
    45         S INST=$O(ORP(DA,INST)) ; multiple?
    46         I INST S ORTX(ORTX)=ORTX(ORTX)_",",Y="" S:NEWLN ORTX=ORTX+1,ORTX(ORTX)="",Y=" " G TXT1
    47         S X=$$GETXT($P(ORP(DA),U,3)) D:$L(X) TXT^ORCHTAB ; trailing text
    48         Q
    49         ;
    50 CHILD(PARENT)   ; -- add child values
    51         N CHSEQ,CHILD S CHSEQ=0
    52         F  S CHSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,CHSEQ)) Q:CHSEQ'>0  S CHILD=$O(^(CHSEQ,0)) D
    53         . Q:'$L($G(ORP(CHILD,INST)))
    54         . S X=$$GETXT($P(ORP(CHILD),U,2)) D:$L(X) TXT^ORCHTAB ; lead text
    55         . S X=ORP(CHILD,INST) D TXT^ORCHTAB
    56         . S X=$$GETXT($P(ORP(CHILD),U,3)) D:$L(X) TXT^ORCHTAB ; trail text
    57         Q
    58         ;
    59 GETXT(X)        ; -- Returns text of X
    60         I $E(X)="@" N VAR S VAR=$E(X,2,99),X=$G(@VAR) K @VAR ; variable w/text
    61         Q X
    62         ;
    63 EXT     ; -- Build ORP(DA) array of external forms
    64         N PROMPT,INST,DA,NODE,FORMAT,OMIT,X,Y,TYPE,PTR
    65         S PROMPT=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
    66         . S DA=+$G(ORDIALOG(PROMPT)),TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
    67         . Q:'DA  S NODE=$G(^ORD(101.41,ORDIALOG,10,DA,2)),FORMAT=$P(NODE,U,2),OMIT=$P(NODE,U,3)
    68         . S:$D(ORDIALOG(PROMPT,"FORMAT")) FORMAT=ORDIALOG(PROMPT,"FORMAT")
    69         . I $E(FORMAT)="@" S PTR=+$E(FORMAT,2,99) Q:'PTR  ; Don't include
    70         . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
    71         . . Q:ORDIALOG(PROMPT,INST)=""
    72         . . I $E(FORMAT)="@",$L($G(ORDIALOG(PTR,INST))) Q  ; use PTR instead
    73         . . I $E(FORMAT)="*" S PTR=+$E(FORMAT,2,99) I '$L($G(ORDIALOG(PTR,INST))) Q  ; must have PTR too
    74         . . I $E(FORMAT)="=" S PTR=+$E(FORMAT,2,99) I PTR,$L($G(ORDIALOG(PTR,INST))) S Y=$$EXT^ORCD(PTR,INST),X=$$EXT^ORCD(PROMPT,INST) I (X=Y)!(X[Y)!(Y[X) Q
    75         . . I TYPE="W" M ORP(DA,INST)=@ORDIALOG(PROMPT,INST)
    76         . . E  S X=$$EXT^ORCD(PROMPT,INST,FORMAT) Q:X=""  Q:OMIT[X  S ORP(DA,INST)=X
    77         . . S ORP(DA)=PROMPT_U_$P(NODE,U,4,7) ; ptr^lead^trail^new line^wrap
    78         Q
    79 DIGTEXT(ORDER,ORDEA,ORSIGNER)    ;Build text used to create Digital Signature
    80         ;ORDER = ifn of order # (file 100)
    81         ;ORDEA = Controlled substance schedule of drug (2-5)
    82         ;ORSIGNER = DUZ of sigining physician
    83         ;ORSET(1)=1)Date of Prescription (RX) -Date Ordered HL7 format 2)Full Patient Name 3)Patient SSN 4)DFN
    84         ;ORSET(2)=5)Patient Street1 6)Patient Street2 7)Patient Street3 8)Patient City 9)Patient State 10)Patient Zip 11)???
    85         ;ORSET(3)=12)Drug name (From Dispense Drug or Orderable Item) 13)Variable ptr for Drug (file 50 or 101.43) 14)Drug quantity prescribed 15)Schedule of medication 16)DEA Schedule
    86         ;ORSET(4)=17)Direction for use
    87         ;ORSET(5)=18)Practitioner's name 19)DUZ 20)Practitioner's (DEA) registration number
    88         ;ORSET(6)=22)SiteName 23)SiteStreet1 24)SiteStreet2 25)SiteCity 26)SiteState 27)SiteZip
    89         ;ORSET(7)=28)$H
    90         N I,DFN,OR80,ORPNM,ORSSN,ORXDT,VAERR,VAPA,X0,X1,X4,X5,X6,X8,X9,X10,X11,X12,X13,X14,SIG
    91         S OR80=$G(^OR(100,ORDER,8,1,0))
    92         Q:'$L(OR80)
    93         S:'$G(ORSIGNER) ORSIGNER=$P(OR80,"^",3)
    94         Q:'ORSIGNER
    95         S $P(^OR(100,ORDER,8,1,2),"^",4,5)=ORDEA_"^"_1 ;Flag to signing process to get digital signature
    96         S ORXDT=$P(OR80,"^"),X1=$$FMTHL7^XLFDT(ORXDT),X4="",X14="",X10=""
    97         I '$D(ORVP) S ORVP=$P(^OR(100,ORDER,0),"^",2)
    98         S DFN=+ORVP
    99         D ADD^VADPT
    100         S ORPNM=^DPT(+ORVP,0),ORSSN=$P(ORPNM,"^",9),ORPNM=$P(ORPNM,"^")
    101         F I=1:1:6 S X4=X4_$S($L($G(VAPA(I))):$S((I=5):$P(VAPA(I),"^",2),1:VAPA(I)),1:"")_"^"
    102         S X11=$$GET1^DIQ(200,ORSIGNER,.01,"E") Q:'$L(X11)
    103         S X12=$$DEA^XUSER(,ORSIGNER)
    104         S X0=$$GET1^DIQ(4,+$G(DUZ(2)),.01,"E")
    105         I $L(X0) S X14=X0_"^"_$$GET1^DIQ(4,DUZ(2),1.01,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.03,"E")_"^"_$$GET1^DIQ(4,DUZ(2),.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.04,"E")
    106         S X5=$$VALUE^ORX8(ORDER,"DRUG",,"E"),X6=$$VALUE^ORX8(ORDER,"DRUG")_";50"
    107         I '$L(X5) S X5=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E"),X6=$$VALUE^ORX8(ORDER,"ORDERABLE")_";101.43"
    108         S X8=$$VALUE^ORX8(ORDER,"QTY",,"E"),X9=$$VALUE^ORX8(ORDER,"SCHEDULE",,"E")
    109         S SIG=+$O(^OR(100,ORDER,4.5,"ID","SIG",0)) I SIG,$L($G(^OR(100,ORDER,4.5,SIG,2,1,0))) S X10=^(0)
    110         S ORSET(1)=X1_"^"_ORPNM_"^"_ORSSN_"^"_+ORVP_"^"
    111         S ORSET(2)=X4_"^"
    112         S ORSET(3)=X5_"^"_X6_"^"_X8_"^"_X9_"^"_ORDEA_"^"
    113         S ORSET(4)=X10_"^"
    114         S ORSET(5)=X11_"^"_ORSIGNER_"^"_X12_"^"
    115         S ORSET(6)=X14
    116         S ORSET(7)=$H
    117         S ORSET=7
    118         Q
     1ORCSAVE1 ; SLC/MKB - Save Order Text ;7/13/04  15:41
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**92,132,141,163,187,223**;Dec 17, 1997
     3 ;
     4 ; ^ORD(101.41,+ORDIALOG,10,ITM,2)=Seq#^Format^Omit^Lead Text^Trail Text
     5 ; ^ORD(101.41,+ORDIALOG,10,"ATXT",Seq#,ITM)=""
     6 ;
     7ORDTEXT(ORDER) ; -- Build and save order text from ORDIALOG() into ORDER
     8 N ORTX,I,IFN,ACT,ORSET
     9 D ORTX(240) Q:'$G(ORTX)
     10 S IFN=+ORDER,ACT=+$P(ORDER,";",2) S:ACT'>0 ACT=1
     11 F I=1:1:ORTX S ^OR(100,IFN,8,ACT,.1,I,0)=ORTX(I)
     12 S ^OR(100,IFN,8,ACT,.1,0)=U_U_ORTX_U_ORTX_U_DT_U
     13 I $E($G(ORDEA))=2 D  ;PKI Drug Schedule - in future may allow 2-5
     14 . S ORSET=0
     15 . D DIGTEXT(IFN,ORDEA)
     16 . F I=1:1:ORSET S ^OR(100,IFN,8,ACT,.2,I,0)=ORSET(I)
     17 . I ORSET>0 S ^OR(100,IFN,8,ACT,.2,0)=U_U_ORSET_U_ORSET_U_DT_U
     18 Q
     19 ;
     20ORTX(WIDTH) ; -- May enter here to return order text in ORTX()
     21 N ORP,SEQ,ITEM,ORMAX
     22 K ORTX S ORMAX=$S(+$G(WIDTH):WIDTH,1:240)
     23 D EXT ; get external form of values
     24 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ)) Q:SEQ'>0  S ITEM=$O(^(SEQ,0)) D TEXT(ITEM)
     25 Q
     26 ;
     27TEXT(DA) ; -- Includes text of item DA
     28 Q:$P(^ORD(101.41,ORDIALOG,10,DA,0),U,11)  Q:'$O(ORP(DA,0))
     29 N NEWLN,INST,TYPE,PTR,CHSEQ,CHILD,ORI,X,Y
     30 S:'$G(ORTX) ORTX=1,ORTX(1)=""
     31 S NEWLN=+$P(ORP(DA),U,4),INST=$O(ORP(DA,0)),Y=""
     32 I NEWLN,$L(ORTX(ORTX)) S ORTX=ORTX+1,ORTX(ORTX)="",Y=" "
     33 S X=$$GETXT($P(ORP(DA),U,2)) I $L(X) S X=Y_X,Y="" D TXT^ORCHTAB ;lead tx
     34 S PTR=+ORP(DA),TYPE=$E(ORDIALOG(PTR,0))
     35TXT1 I TYPE'="W" S X=Y_ORP(DA,INST),Y="" D TXT^ORCHTAB
     36 I TYPE="W" S ORI=0 F  S ORI=$O(ORP(DA,INST,ORI)) Q:ORI'>0  D  S Y=""
     37 . S Y=$S(Y=" ":" ",$P(ORP(DA),U,5):" ",1:"") ;new line, or as stored
     38 . S X=Y_ORP(DA,INST,ORI,0),Y=""
     39 . I $E(X)'=" " D TXT^ORCHTAB Q  ; wrap
     40 . S:$L(ORTX(ORTX)) ORTX=ORTX+1,ORTX(ORTX)="" ; force new line
     41 . I X?1." " S ORTX(ORTX)=" ",ORTX=ORTX+1,ORTX(ORTX)="" ; blank line
     42 . E  D TXT^ORCHTAB
     43 D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PTR)) CHILD(PTR)
     44 S INST=$O(ORP(DA,INST)) ; multiple?
     45 I INST S ORTX(ORTX)=ORTX(ORTX)_",",Y="" S:NEWLN ORTX=ORTX+1,ORTX(ORTX)="",Y=" " G TXT1
     46 S X=$$GETXT($P(ORP(DA),U,3)) D:$L(X) TXT^ORCHTAB ; trailing text
     47 Q
     48 ;
     49CHILD(PARENT) ; -- add child values
     50 N CHSEQ,CHILD S CHSEQ=0
     51 F  S CHSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,CHSEQ)) Q:CHSEQ'>0  S CHILD=$O(^(CHSEQ,0)) D
     52 . Q:'$L($G(ORP(CHILD,INST)))
     53 . S X=$$GETXT($P(ORP(CHILD),U,2)) D:$L(X) TXT^ORCHTAB ; lead text
     54 . S X=ORP(CHILD,INST) D TXT^ORCHTAB
     55 . S X=$$GETXT($P(ORP(CHILD),U,3)) D:$L(X) TXT^ORCHTAB ; trail text
     56 Q
     57 ;
     58GETXT(X) ; -- Returns text of X
     59 I $E(X)="@" N VAR S VAR=$E(X,2,99),X=$G(@VAR) K @VAR ; variable w/text
     60 Q X
     61 ;
     62EXT ; -- Build ORP(DA) array of external forms
     63 N PROMPT,INST,DA,NODE,FORMAT,OMIT,X,Y,TYPE,PTR
     64 S PROMPT=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
     65 . S DA=+$G(ORDIALOG(PROMPT)),TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
     66 . Q:'DA  S NODE=$G(^ORD(101.41,ORDIALOG,10,DA,2)),FORMAT=$P(NODE,U,2),OMIT=$P(NODE,U,3)
     67 . S:$D(ORDIALOG(PROMPT,"FORMAT")) FORMAT=ORDIALOG(PROMPT,"FORMAT")
     68 . I $E(FORMAT)="@" S PTR=+$E(FORMAT,2,99) Q:'PTR  ; Don't include
     69 . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
     70 . . Q:ORDIALOG(PROMPT,INST)=""
     71 . . I $E(FORMAT)="@",$L($G(ORDIALOG(PTR,INST))) Q  ; use PTR instead
     72 . . I $E(FORMAT)="*" S PTR=+$E(FORMAT,2,99) I '$L($G(ORDIALOG(PTR,INST))) Q  ; must have PTR too
     73 . . I $E(FORMAT)="=" S PTR=+$E(FORMAT,2,99) I PTR,$L($G(ORDIALOG(PTR,INST))) S Y=$$EXT^ORCD(PTR,INST),X=$$EXT^ORCD(PROMPT,INST) I (X=Y)!(X[Y)!(Y[X) Q
     74 . . I TYPE="W" M ORP(DA,INST)=@ORDIALOG(PROMPT,INST)
     75 . . E  S X=$$EXT^ORCD(PROMPT,INST,FORMAT) Q:X=""  Q:OMIT[X  S ORP(DA,INST)=X
     76 . . S ORP(DA)=PROMPT_U_$P(NODE,U,4,7) ; ptr^lead^trail^new line^wrap
     77 Q
     78DIGTEXT(ORDER,ORDEA,ORSIGNER)  ;Build text used to create Digital Signature
     79 ;ORDER = ifn of order # (file 100)
     80 ;ORDEA = Controlled substance schedule of drug (2-5)
     81 ;ORSIGNER = DUZ of sigining physician
     82 ;ORSET(1)=1)Date of Prescription (RX) -Date Ordered HL7 format 2)Full Patient Name 3)Patient SSN 4)DFN
     83 ;ORSET(2)=5)Patient Street1 6)Patient Street2 7)Patient Street3 8)Patient City 9)Patient State 10)Patient Zip 11)???
     84 ;ORSET(3)=12)Drug name (From Dispense Drug or Orderable Item) 13)Variable ptr for Drug (file 50 or 101.43) 14)Drug quantity prescribed 15)Schedule of medication 16)DEA Schedule
     85 ;ORSET(4)=17)Direction for use
     86 ;ORSET(5)=18)Practitioner's name 19)DUZ 20)Practitioner's (DEA) registration number
     87 ;ORSET(6)=22)SiteName 23)SiteStreet1 24)SiteStreet2 25)SiteCity 26)SiteState 27)SiteZip
     88 ;ORSET(7)=28)$H
     89 N I,DFN,OR80,ORPNM,ORSSN,ORXDT,VAERR,VAPA,X0,X1,X4,X5,X6,X8,X9,X10,X11,X12,X13,X14,SIG
     90 S OR80=$G(^OR(100,ORDER,8,1,0))
     91 Q:'$L(OR80)
     92 S:'$G(ORSIGNER) ORSIGNER=$P(OR80,"^",3)
     93 Q:'ORSIGNER
     94 S $P(^OR(100,ORDER,8,1,2),"^",4,5)=ORDEA_"^"_1 ;Flag to signing process to get digital signature
     95 S ORXDT=$P(OR80,"^"),X1=$$FMTHL7^XLFDT(ORXDT),X4="",X14="",X10=""
     96 I '$D(ORVP) S ORVP=$P(^OR(100,ORDER,0),"^",2)
     97 S DFN=+ORVP
     98 D ADD^VADPT
     99 S ORPNM=^DPT(+ORVP,0),ORSSN=$P(ORPNM,"^",9),ORPNM=$P(ORPNM,"^")
     100 F I=1:1:6 S X4=X4_$S($L($G(VAPA(I))):$S((I=5):$P(VAPA(I),"^",2),1:VAPA(I)),1:"")_"^"
     101 S X11=$$GET1^DIQ(200,ORSIGNER,.01,"E") Q:'$L(X11)
     102 S X12=$$DEA^XUSER(,ORSIGNER)
     103 S X0=$$GET1^DIQ(4,+$G(DUZ(2)),.01,"E")
     104 I $L(X0) S X14=X0_"^"_$$GET1^DIQ(4,DUZ(2),1.01,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.03,"E")_"^"_$$GET1^DIQ(4,DUZ(2),.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.04,"E")
     105 S X5=$$VALUE^ORX8(ORDER,"DRUG",,"E"),X6=$$VALUE^ORX8(ORDER,"DRUG")_";50"
     106 I '$L(X5) S X5=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E"),X6=$$VALUE^ORX8(ORDER,"ORDERABLE")_";101.43"
     107 S X8=$$VALUE^ORX8(ORDER,"QTY",,"E"),X9=$$VALUE^ORX8(ORDER,"SCHEDULE",,"E")
     108 S SIG=+$O(^OR(100,ORDER,4.5,"ID","SIG",0)) I SIG,$L($G(^OR(100,ORDER,4.5,SIG,2,1,0))) S X10=^(0)
     109 S ORSET(1)=X1_"^"_ORPNM_"^"_ORSSN_"^"_+ORVP_"^"
     110 S ORSET(2)=X4_"^"
     111 S ORSET(3)=X5_"^"_X6_"^"_X8_"^"_X9_"^"_ORDEA_"^"
     112 S ORSET(4)=X10_"^"
     113 S ORSET(5)=X11_"^"_ORSIGNER_"^"_X12_"^"
     114 S ORSET(6)=X14
     115 S ORSET(7)=$H
     116 S ORSET=7
     117 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE2.m

    r613 r623  
    1 ORCSAVE2        ;SLC/MKB-Utilities to update an order ; 4/8/08 12:04pm
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 STATUS(IFN,ST)  ; -- Update status of order
    6         Q:'$G(IFN)  Q:'$D(^OR(100,+IFN,0))  Q:$P($G(^(3)),U,3)=$G(ST)  ;no change
    7         Q:'$G(ST)  Q:'$D(^ORD(100.01,+ST,0))
    8         N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP
    9         S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT
    10         S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3
    11         I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12))
    12         I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN
    13         I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent
    14         D SETALL^ORDD100(+IFN)
    15         Q
    16         ;
    17 CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate
    18         N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS
    19         Q:'$D(^OR(100,ORIFN,0))  S ORSTS=$P($G(^(3)),U,3)
    20         I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D  Q  ;Parent unrel'd - ck children
    21         . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0  D  Q:'ALLRELSD
    22         . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
    23         . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0
    24         . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending
    25         S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0
    26         F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0  D  Q:'ALLDONE
    27         . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
    28         . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q
    29         . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q
    30         . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q
    31         . S ALLDONE=0 S:CHSTS=6 ACTIVE=1
    32         I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q
    33         I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active
    34         Q
    35         ;
    36 RELEASE(ORDER,ACTION,WHEN,WHO,NATURE)   ; -- Mark order as released to service
    37         S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
    38         Q:'$G(ORDER)  N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0))
    39         S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0)))
    40         S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)=""
    41         ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)=""
    42         S $P(OR0,U,16,17)=WHEN_U_WHO
    43         S ^OR(100,ORDER,8,ACTION,0)=OR0
    44         I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER)
    45         ;Set the "AR" index.
    46         D RS^ORDD100(ORDER,ACTION,ORVP,WHEN)
    47         Q
    48         ;
    49 STARTDT(DA)     ; -- resolve Start and Stop dates from Responses
    50         N X,Y,%DT,ORDG,ORT,ORLAB
    51         S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3)
    52         S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT=""
    53         S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA)
    54 STRT    S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q  S:$L(ORT) X=X_"@"_ORT
    55         D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST"
    56         S %DT="T" D ^%DT Q:Y'>0  S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
    57         S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
    58 STOP    I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1  S X=$$FMADD^XLFDT(Y,(X-1))
    59         I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X)  S:$L(ORT) X=X_"@"_ORT
    60         S %DT="T" D ^%DT Q:Y'>0  S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
    61         S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A
    62         Q
    63         ;
    64 NEXT    ; -- Resolve next lab collection to FM date/time
    65         N ORTIME,ORDAY,NOW,NEXT,ENT
    66         ;is referenced by DBIA #964
    67         S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"
    68         D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
    69         S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1")
    70         S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0
    71         S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U)
    72         Q
    73         ;
    74 AM      ; -- Resolve AM lab collection to FM date/time
    75         N ORTIME,ORDAY,AM,NOW,ENT
    76         ;is referenced by DBIA #964
    77         S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"
    78         D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
    79         S AM=$O(ORTIME(0)),NOW=$P($H,",",2)
    80         S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1")
    81         S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U)
    82         Q
    83         ;
    84 ADMIN(START)    ; -- Resolve next/closest administration times to FM date/time
    85         N PAT,SCH,OI,LOC,Y,I
    86         I $G(DA) D  ;get data from order DA
    87         . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC=""
    88         . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first
    89         . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE")
    90         I '$G(DA) D  ;or look in ORDIALOG() instead
    91         . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0))
    92         . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I))
    93         . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC=""
    94         S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI
    95         ;is referenced by DBIA #3167
    96         S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2)
    97         Q
    98         ;
    99 SIGN(DA,WHO,WHEN,HOW,WHAT)      ; -- affix ES to order
    100         Q:'$G(DA)  S:'$G(WHAT) WHAT=1
    101         N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref
    102         S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"")
    103         ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer
    104         S ^OR(100,DA,8,WHAT,0)=X
    105         D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref
    106         Q
    107         ;
    108 SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns]
    109         ; Expects ORNATR, ORVP, ORNP to be defined
    110         Q:'$G(IFN)  Q:'$G(ACT)  N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U)
    111         S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3)
    112         K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)
    113         S $P(^OR(100,+IFN,8,ACT,0),U,4)=X
    114         I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN
    115         Q
    116         ;
    117 UNVEIL(IFN)     ; -- unveil new order
    118         S $P(^OR(100,IFN,3),U,8)=""
    119         Q
    120         ;
    121 DELETE(ORDER)   ; -- delete order [action]
    122         N DIK,DA,DAD
    123         I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q
    124         S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent
    125         K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text
    126         Q
    127         ;
    128 VERIFY(IFN,DA,TYPE,WHO,WHEN)    ; -- order verified
    129         Q:'$G(IFN)  Q:'$G(DA)  Q:"^N^C^R^"'[(U_$G(TYPE)_U)
    130         N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18)
    131         S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
    132         S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN
    133         D:$L($T(VER^EDPFMON)) VER^EDPFMON(IFN)
    134         Q
    135         ;
    136 COMP(IFN,WHO,WHEN)      ; -- order completed
    137         Q:'$G(IFN)  S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
    138         D DATES(+IFN,,WHEN),STATUS(+IFN,2)
    139         S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO
    140         D:$L($T(COMP^EDPFMON)) COMP^EDPFMON(IFN)
    141         Q
    142         ;
    143 DATES(DA,START,STOP)    ; -- Update start/stop dates for order DA
    144         Q:'$G(DA)  I $G(START) D
    145         . Q:START=$P(^OR(100,DA,0),U,8)
    146         . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA)
    147         . S $P(^OR(100,DA,0),U,8)=START
    148         . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
    149         I $G(STOP) D
    150         . ;Q:STOP=$P(^OR(100,DA,0),U,9)  ;ck xref anyway
    151         . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A
    152         Q
    153         ;
    154 OC      ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9)
    155         Q:'$G(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))  K ^OR(100,+ORIFN,9)
    156         N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0
    157         S CDL=0 F  S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0  D
    158         . S I=0 F  S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0  D
    159         . . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC
    160         . . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW
    161         . . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)=""
    162         . . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245)
    163         S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
    164         Q
    165         ;
    166 VALUE(IFN,ID,INST)      ; -- Returns value of prompt by identifier ID
    167         I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""
    168         N I,Y S I=0,Y="" S:'$G(INST) INST=1
    169         F  S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0  I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q
    170         Q Y
    171         ;
    172 SC(ORX,ORIFN)   ; -- save responses to SC questions
    173         Q:'$G(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))  ;invalid order number
    174         N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0
    175         F I="SC","MST","AO","IR","EC","HNC","CV","SHD" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I)
    176         S ^OR(100,+ORIFN,5)=OR5
    177         Q
    178         ;
    179 CANCEL(ORDER)   ; -- cancel order [action]
    180         N ORA,DIE,DA,DR,ORX
    181         S ORDER=$G(ORDER),ORA=+$P(ORDER,";",2) Q:'ORA!('ORDER)
    182         I $D(^OR(100,+ORDER,8,ORA)) D
    183         .S ORX="Unsigned/unreleased order cancelled by provider"
    184         .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
    185         .S DR="4////5;15////13;1////^S X=ORX" D ^DIE
    186         I ORA=1 D
    187         .K DA S DIE="^OR(100,",DA=+ORDER,DR="5////13" D ^DIE
    188         Q
    189         ;
    190 LAPSE(ORDER)    ; -- lapse order [action]
    191         N ORA S ORA=+$P(ORDER,";",2)
    192         Q:'$D(^OR(100,+ORDER,0))  Q:'ORA!('ORDER)
    193         I $D(^OR(100,+ORDER,8,ORA)) D
    194         .N DIE,DA,DR
    195         .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
    196         .S DR="4////5;15////14" D ^DIE
    197         I ORA=1 D
    198         .N DIE,DA,DR
    199         .S DIE="^OR(100,",DA=+ORDER,DR="5////14"
    200         .D ^DIE,ALPS(DA,ORA)
    201         Q
    202 ALPS(DA,ORACT,TYPE)     ;set the lapse index ^OR(100,"ALPS")
    203         N ORVP,X,OR0,ORLOG
    204         S OR0=$G(^OR(100,DA,8,ORACT,0))
    205         S ORLOG=$P(OR0,U),ORVP=$P($G(^OR(100,DA,0)),U,2)
    206         I ORVP,ORLOG S ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$G(TYPE)
    207         S ^OR(100,DA,10)=$$NOW^XLFDT
    208         Q
    209         ;
    210 RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue
    211         S IFN=+$G(IFN),VAL=$G(VAL),PRMT=+$O(^ORD(101.41,"AB",PRMT,0))
    212         N ID,DA,DIK S:'$G(INST) INST=1
    213         S ID=$P($G(^ORD(101.41,PRMT,1)),U,3) Q:'$L(ID)
    214         S DA=0 F  S DA=$O(^OR(100,IFN,4.5,"ID",ID,DA)) Q:DA<1  Q:$P($G(^OR(100,IFN,4.5,DA,0)),U,3)=INST
    215         I 'DA D:$L(VAL)  Q  ;add
    216         . N DO,DIC,DLG,X
    217         . S DIC="^OR(100,"_IFN_",4.5,",DA(1)=IFN,DIC(0)="FL"
    218         . S DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID
    219         . S DLG=+$P($G(^OR(100,IFN,0)),U,5)
    220         . S X=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
    221         . D FILE^DICN S:Y ^OR(100,IFN,4.5,+Y,1)=VAL
    222         I $L(VAL) S ^OR(100,IFN,4.5,DA,1)=VAL Q  ;change
    223         S DIK="^OR(100,"_IFN_",4.5,",DA(1)=IFN D ^DIK ;delete
    224         Q
     1ORCSAVE2 ;SLC/MKB-Utilities to update an order ;04:19 PM  06/16/2004
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265**;Dec 17, 1997;Build 17
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5STATUS(IFN,ST) ; -- Update status of order
     6 Q:'$G(IFN)  Q:'$D(^OR(100,+IFN,0))  Q:$P($G(^(3)),U,3)=$G(ST)  ;no change
     7 Q:'$G(ST)  Q:'$D(^ORD(100.01,+ST,0))
     8 N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP
     9 S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT
     10 S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3
     11 I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12))
     12 I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN
     13 I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent
     14 D SETALL^ORDD100(+IFN)
     15 Q
     16 ;
     17CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate
     18 N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS
     19 Q:'$D(^OR(100,ORIFN,0))  S ORSTS=$P($G(^(3)),U,3)
     20 I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D  Q  ;Parent unrel'd - ck children
     21 . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0  D  Q:'ALLRELSD
     22 . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
     23 . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0
     24 . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending
     25 S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0
     26 F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0  D  Q:'ALLDONE
     27 . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
     28 . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q
     29 . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q
     30 . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q
     31 . S ALLDONE=0 S:CHSTS=6 ACTIVE=1
     32 I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q
     33 I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active
     34 Q
     35 ;
     36RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service
     37 S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
     38 Q:'$G(ORDER)  N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0))
     39 S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0)))
     40 S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)=""
     41 ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)=""
     42 S $P(OR0,U,16,17)=WHEN_U_WHO
     43 S ^OR(100,ORDER,8,ACTION,0)=OR0
     44 I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER)
     45 ;Set the "AR" index.
     46 D RS^ORDD100(ORDER,ACTION,ORVP,WHEN)
     47 Q
     48 ;
     49STARTDT(DA) ; -- resolve Start and Stop dates from Responses
     50 N X,Y,%DT,ORDG,ORT,ORLAB
     51 S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3)
     52 S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT=""
     53 S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA)
     54STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q  S:$L(ORT) X=X_"@"_ORT
     55 D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST"
     56 S %DT="T" D ^%DT Q:Y'>0  S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
     57 S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
     58STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1  S X=$$FMADD^XLFDT(Y,(X-1))
     59 I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X)  S:$L(ORT) X=X_"@"_ORT
     60 S %DT="T" D ^%DT Q:Y'>0  S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
     61 S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A
     62 Q
     63 ;
     64NEXT ; -- Resolve next lab collection to FM date/time
     65 N ORTIME,ORDAY,NOW,NEXT,ENT
     66 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"   ;is referenced by DBIA #964
     67 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
     68 S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1")
     69 S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0
     70 S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U)
     71 Q
     72 ;
     73AM ; -- Resolve AM lab collection to FM date/time
     74 N ORTIME,ORDAY,AM,NOW,ENT
     75 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"   ;is referenced by DBIA #964
     76 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
     77 S AM=$O(ORTIME(0)),NOW=$P($H,",",2)
     78 S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1")
     79 S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U)
     80 Q
     81 ;
     82ADMIN(START) ; -- Resolve next/closest administration times to FM date/time
     83 N PAT,SCH,OI,LOC,Y,I
     84 I $G(DA) D  ;get data from order DA
     85 . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC=""
     86 . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first
     87 . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE")
     88 I '$G(DA) D  ;or look in ORDIALOG() instead
     89 . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0))
     90 . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I))
     91 . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC=""
     92 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI
     93 S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2)   ;is referenced by DBIA #3167
     94 Q
     95 ;
     96SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order
     97 Q:'$G(DA)  S:'$G(WHAT) WHAT=1
     98 N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref
     99 S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"")
     100 ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer
     101 S ^OR(100,DA,8,WHAT,0)=X
     102 D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref
     103 Q
     104 ;
     105SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns]
     106 ; Expects ORNATR, ORVP, ORNP to be defined
     107 Q:'$G(IFN)  Q:'$G(ACT)  N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U)
     108 S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3)
     109 K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)
     110 S $P(^OR(100,+IFN,8,ACT,0),U,4)=X
     111 I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN
     112 Q
     113 ;
     114UNVEIL(IFN) ; -- unveil new order
     115 S $P(^OR(100,IFN,3),U,8)=""
     116 Q
     117 ;
     118DELETE(ORDER) ; -- delete order [action]
     119 N DIK,DA,DAD
     120 I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q
     121 S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent
     122 K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text
     123 Q
     124 ;
     125VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified
     126 Q:'$G(IFN)  Q:'$G(DA)  Q:"^N^C^R^"'[(U_$G(TYPE)_U)
     127 N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18)
     128 S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
     129 S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN
     130 Q
     131 ;
     132COMP(IFN,WHO,WHEN) ; -- order completed
     133 Q:'$G(IFN)  S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
     134 D DATES(+IFN,,WHEN),STATUS(+IFN,2)
     135 S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO
     136 Q
     137 ;
     138DATES(DA,START,STOP) ; -- Update start/stop dates for order DA
     139 Q:'$G(DA)  I $G(START) D
     140 . Q:START=$P(^OR(100,DA,0),U,8)
     141 . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA)
     142 . S $P(^OR(100,DA,0),U,8)=START
     143 . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
     144 I $G(STOP) D
     145 . ;Q:STOP=$P(^OR(100,DA,0),U,9)  ;ck xref anyway
     146 . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A
     147 Q
     148 ;
     149OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9)
     150 Q:'$G(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))  K ^OR(100,+ORIFN,9)
     151 N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0
     152 S CDL=0 F  S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0  D
     153 . S I=0 F  S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0  D
     154 . . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC
     155 . . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW
     156 . . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)=""
     157 . . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245)
     158 S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
     159 Q
     160 ;
     161VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID
     162 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""
     163 N I,Y S I=0,Y="" S:'$G(INST) INST=1
     164 F  S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0  I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q
     165 Q Y
     166 ;
     167SC(ORX,ORIFN) ; -- save responses to SC questions
     168 Q:'$G(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))  ;invalid order number
     169 N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0
     170 F I="SC","MST","AO","IR","EC","HNC","CV" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I)
     171 S ^OR(100,+ORIFN,5)=OR5
     172 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND.m

    r613 r623  
    1 ORCSEND ;SLC/MKB-Release orders ; 11/8/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR)      ; -- Release [actions on] orders
    5         N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER
    6         S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR=""
    7         S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"")
    8         S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12)
    9         S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)
    10         I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D  ; sign/alert
    11         . I 'SIGNED D NOTIF^ORCSIGN Q
    12         . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
    13         . D:SIGSTS=4 CHART^ORCSIGN ; not used anymore
    14         I '$L(ACTION) S ORERR="1^Invalid order action" Q
    15         I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D
    16         . N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1
    17         . I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES")
    18         ; If order originated from the back door, send Dx and TxF back to ancil.
    19         I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7
    20         Q
    21         ;
    22 EN1(ORDER,ORERR)        ; -- Delayed Release [from RELEASE^ORMEVNT]
    23         ;
    24         Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10
    25         N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS
    26         S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0))
    27         S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3)
    28         S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2)
    29         S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0) I RELSTS D
    30         . D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT)
    31         . S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ)
    32         . D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN)
    33         . I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error
    34         I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11
    35         Q
    36         ;
    37 EN2(ORIFN,SIGSTS,NATURE,ORERR)  ; -- Manual Release [from OREVNT1,SENDED^ORWDX]
    38         N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS
    39         S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1
    40         S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0))
    41         S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1
    42         S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR="" I $P(ORA0,U,4)=2 D  ;needs ES
    43         . N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"")
    44         . I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q  ;still unsigned
    45         . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
    46         D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN")
    47         Q
    48         ;
    49 NW      ; -- New order ORIFN
    50 RW      ; -- Rewritten order ORIFN
    51 XX      ; -- Changed order ORIFN
    52 RN      ; -- Renewed order ORIFN
    53         N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE
    54         N IVDIEN,IVPKGM
    55         S IVPKGM=0
    56         S IVDIEN=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
    57         I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q
    58         S:'ORDA ORDA=1 S ORSAVE=ORIFN
    59         S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN)
    60         S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW"
    61         I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
    62         I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSJ" S IVPKGM=1
    63         I IVPKGM=1,$P($P(OR0,U,5),";")=IVDIEN D PSJI^ORCSEND3 Q:$G(ORQUIT)
    64         I IVPKGM=0!($P($P(OR0,U,5),";")'=IVDIEN) D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT)
    65         D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
    66         D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3)
    67         I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6)
    68         I STS=11 S ORERR="1^ERROR"
    69         Q
    70         ;
    71 DC      ; -- DC order ORIFN
    72         N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3,OR6,DCNATURE
    73         I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0))
    74         S:$G(REASON) $P(^OR(100,ORIFN,6),U,1,5)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U)
    75         I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
    76         S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4)
    77         S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC")
    78         D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
    79 DC1     I $O(^OR(100,ORIFN,2,0)) D  G DC2 ; DC children
    80         . S ORCHLD=0 F  S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0  I $$VALID^ORCACT0(ORCHLD,"DC") D  Q:$G(ORERR)
    81         . . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0)
    82         . . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,8,ORCHDA) ;Sig on Parent only
    83         . . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON))
    84         . . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA)
    85         . ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1)
    86         . S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2)
    87         D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON))
    88 DC2     S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3)
    89         S OR6=$G(^OR(100,ORIFN,6))
    90         I STS'=1,STS'=13,STS'=2 D  Q
    91         . S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue")
    92         . I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd
    93         . K ^OR(100,ORIFN,6)
    94         S DCNATURE=$S(+OR6:+OR6,1:$G(NATURE))
    95         S $P(^OR(100,ORIFN,3),U,7)=$S('$$ACTV^ORX1($G(DCNATURE)):0,1:$P(OR3,U,7))
    96         D CANCEL(ORIFN),SETALL^ORDD100(ORIFN)
    97         I $P(OR3,U,11)=2 D  ; dc a renewal
    98         . N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG
    99         . ;I CODE="CA",+$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q  ;pend - remove fwd ptr
    100         . I +$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q  ;pend - remove fwd ptr
    101         . Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U)  S NATR=$O(^ORD(100.02,"C","A",0))
    102         . S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled"
    103         . D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q
    104         . S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0
    105         Q
    106         ;
    107 CANCEL(IFN)     ; -- Cancel any outstanding actions for order IFN
    108         N I S I=0
    109         F  S I=$O(^OR(100,IFN,8,I)) Q:I'>0  I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now
    110         Q
    111         ;
    112 HD      ; -- Hold order ORIFN
    113         N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q
    114         I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
    115         D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
    116         S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE
    117         S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA)
    118         I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG
    119         Q
    120         ;
    121 RL      ; -- Release hold on order ORIFN
    122         N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q
    123         I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
    124         D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
    125         S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE
    126         S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7)
    127         I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA)
    128         I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG
    129         Q
    130         ;
    131 FL      ; -- Flag order ORIFN
    132         Q
    133         ;
    134 UF      ; -- Unflag order ORIFN
    135         Q
    136         ;
    137 CM      ; -- Add Ward comments to order ORIFN
    138         Q
    139         ;
    140 VR      ; -- Verify order ORIFN
    141         I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q
    142         I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q
    143         D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW)
    144         ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending]
    145         Q:ORVER'="N"  N ORSTS,ORPKG,ORX
    146         S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) Q:ORX'="NW"&(ORX'="XX")
    147         S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3)
    148         ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN)
    149         I $$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN)
    150         Q
    151         ;
    152 NEEDSIG()       ; -- Msg
    153         Q "1^This order requires a signature."
    154         ;
    155 WHY(IFN,DA)     ; -- Return reason request was rejected
    156         N X S X=$G(^OR(100,IFN,8,DA,1))
    157         S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release")
    158         Q X
    159         ;
    160 NOSIG   ; -- Mark order as Sig not Req'd due to cancel/reject
    161         D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0
    162         Q
    163         ;
    164 READY(IFN,ACT)  ; -- Ready to release?
    165         N X,Y,OR0,OR3,ORA
    166         I ACTION="VR" S Y=1 G RQ ; no action to release
    167         I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate
    168         S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0))
    169         I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased
    170         I $P(ORA,U,15)=10 D  G RQ ; delayed
    171         . I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q
    172         . Q:'RELSTS  N ORIG S ORIG=+$P(OR3,U,5)
    173         . I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA
    174         . Q:$P(OR3,U,11)'=1!('ORIG)  ;dc original if signed edit
    175         . D STATUS^ORCSAVE2(ORIG,12)
    176         . S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
    177         . S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1)
    178         I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old)
    179 RQ      I +$$SWSTAT^IBBAPI() D:Y=1 EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228 IA #4663
    180         Q Y
     1ORCSEND ;SLC/MKB-Release orders ; 08 May 2002  2:12 PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,228**;Dec 17, 1997
     3 ;
     4EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders
     5 N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER
     6 S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR=""
     7 S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"")
     8 S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12)
     9 S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)
     10 I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D  ; sign/alert
     11 . I 'SIGNED D NOTIF^ORCSIGN Q
     12 . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
     13 . D:SIGSTS=4 CHART^ORCSIGN ; not used anymore
     14 I '$L(ACTION) S ORERR="1^Invalid order action" Q
     15 I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D
     16 . N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1
     17 . I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES")
     18 ; If order originated from the back door, send Dx and TxF back to ancil.
     19 I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7
     20 Q
     21 ;
     22EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT]
     23 ;
     24 Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10
     25 N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS
     26 S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0))
     27 S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3)
     28 S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2)
     29 S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0)
     30 I RELSTS D
     31 . D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT)
     32 . S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ)
     33 . D EDO1^ORWPFSS1  ;PFSS Event Delayed Orders
     34 . D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN)
     35 . I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error
     36 I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11
     37 Q
     38 ;
     39EN2(ORIFN,SIGSTS,NATURE,ORERR)  ; -- Manual Release [from OREVNT1,SENDED^ORWDX]
     40 N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS
     41 S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1
     42 S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0))
     43 S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1
     44 S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR=""
     45 I $P(ORA0,U,4)=2 D  ;needs ES
     46 . N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"")
     47 . I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q  ;still unsigned
     48 . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
     49 D EDO2^ORWPFSS1  ;PFSS Event Delayed Orders
     50 D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN")
     51 Q
     52 ;
     53NW ; -- New order ORIFN
     54RW ; -- Rewritten order ORIFN
     55XX ; -- Changed order ORIFN
     56RN ; -- Renewed order ORIFN
     57 N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE
     58 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q
     59 S:'ORDA ORDA=1 S ORSAVE=ORIFN
     60 S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN)
     61 S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW"
     62 I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
     63 D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT)
     64 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
     65 D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3)
     66 I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6)
     67 I STS=11 S ORERR="1^ERROR"
     68 Q
     69 ;
     70DC ; -- DC order ORIFN
     71 N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3
     72 I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0))
     73 S:$G(REASON) ^OR(100,ORIFN,6)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U)
     74 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
     75 S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4)
     76 S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC")
     77 D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
     78DC1 I $O(^OR(100,ORIFN,2,0)) D  G DC2 ; DC children
     79 . S ORCHLD=0 F  S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0  I $$VALID^ORCACT0(ORCHLD,"DC") D  Q:$G(ORERR)
     80 . . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0)
     81 . . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,"",ORCHDA) ;Sig on Parent only
     82 . . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON))
     83 . . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA)
     84 . ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1)
     85 . S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2)
     86 D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON))
     87DC2 S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3)
     88 I STS'=1,STS'=13,STS'=2 D  Q
     89 . S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue")
     90 . I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd
     91 . K ^OR(100,ORIFN,6)
     92 S $P(^OR(100,ORIFN,3),U,7)=$S(ORDA:ORDA,'$$ACTV^ORX1($G(NATURE)):0,1:$P(OR3,U,7))
     93 D CANCEL(ORIFN),SETALL^ORDD100(ORIFN)
     94 I $P(OR3,U,11)=2 D  ; dc a renewal
     95 . N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG
     96 . I CODE="CA" S $P(^OR(100,ORIG,3),U,6)="" Q  ;pend - remove fwd ptr
     97 . Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U)  S NATR=$O(^ORD(100.02,"C","A",0))
     98 . S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled"
     99 . D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q
     100 . S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0
     101 Q
     102 ;
     103CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN
     104 N I S I=0
     105 F  S I=$O(^OR(100,IFN,8,I)) Q:I'>0  I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now
     106 Q
     107 ;
     108HD ; -- Hold order ORIFN
     109 N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q
     110 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
     111 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
     112 S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE
     113 S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA)
     114 I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG
     115 Q
     116 ;
     117RL ; -- Release hold on order ORIFN
     118 N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q
     119 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
     120 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
     121 S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE
     122 S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7)
     123 I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA)
     124 I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG
     125 Q
     126 ;
     127FL ; -- Flag order ORIFN
     128 Q
     129 ;
     130UF ; -- Unflag order ORIFN
     131 Q
     132 ;
     133CM ; -- Add Ward comments to order ORIFN
     134 Q
     135 ;
     136VR ; -- Verify order ORIFN
     137 I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q
     138 I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q
     139 D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW)
     140 ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending]
     141 Q:ORVER'="N"  N ORSTS,ORPKG,ORX
     142 S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) Q:ORX'="NW"&(ORX'="XX")
     143 S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3)
     144 ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN)
     145 I $$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN)
     146 Q
     147 ;
     148NEEDSIG() ; -- Msg
     149 Q "1^This order requires a signature."
     150 ;
     151WHY(IFN,DA) ; -- Return reason request was rejected
     152 N X S X=$G(^OR(100,IFN,8,DA,1))
     153 S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release")
     154 Q X
     155 ;
     156NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject
     157 D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0
     158 Q
     159 ;
     160READY(IFN,ACT) ; -- Ready to release?
     161 N X,Y,OR0,OR3,ORA
     162 I ACTION="VR" S Y=1 G RQ ; no action to release
     163 I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate
     164 S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0))
     165 I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased
     166 I $P(ORA,U,15)=10 D  G RQ ; delayed
     167 . I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q
     168 . Q:'RELSTS  N ORIG S ORIG=+$P(OR3,U,5)
     169 . I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA
     170 . Q:$P(OR3,U,11)'=1!('ORIG)  ;dc original if signed edit
     171 . D STATUS^ORCSAVE2(ORIG,12)
     172 . S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
     173 . S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1)
     174 I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old)
     175RQ I Y=1 D EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228
     176 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND1.m

    r613 r623  
    1 ORCSEND1        ;SLC/MKB-Release cont ;11/22/06
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 PKGSTUFF(PKG)   ; Package code
    5         S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG)
    6         D:$L($T(@PKG)) @PKG
    7         Q
    8 LR      ; Spawn child orders if continuous schedule
    9         N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS
    10         S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10)
    11         D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D  Q
    12         . N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8)
    13         . D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule
    14         S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11)
    15         D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1
    16         K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1)
    17         S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
    18         S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE")
    19         S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN")
    20         S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY")
    21         S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
    22         S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE")
    23         S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME")
    24 LR1     S ORS1=0 F  S ORS1=$O(ORX(ORS1)) Q:ORS1'>0  D
    25         . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance
    26         . S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1))
    27         . S ORS2=0 F  S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0  D
    28         .. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
    29         .. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC")
    30         .. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC")
    31         .. D CHILD^ORCSEND3()
    32         S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
    33         S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3)
    34         I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders"
    35         D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE))
    36         Q
    37 SCHEDULE(IFN,PKG,ORY,STRT)      ; Returns list of start time(s) from schedule
    38         N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR
    39         S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q
    40         S ORY=1,ORY(PSJSD)="" ;1st occurrance
    41         S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I  Q:'$L($G(PKG))
    42         S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X)
    43         S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX))
    44         I $G(PSJTS)'="C",$G(PSJTS)'="D" Q  ;not continuous or day-of-week
    45         S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I
    46         S ORDUR=$G(^OR(100,+IFN,4.5,+I,1))
    47         S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1)
    48         I 'ORDUR S X=+$E(ORDUR,2,9) D
    49         . I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times
    50         . E  D  ;no freq in minutes --> day of week
    51         .. N DAYS,LOCMX,SCHMX
    52         .. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
    53         .. K ^TMP($J,"ORCSEND1 SCHEDULE")
    54         .. D ZERO^PSS51P1(PSJY,,,,"ORCSEND1 SCHEDULE")
    55         .. S SCHMX=+$G(^TMP($J,"ORCSEND1 SCHEDULE",PSJY,2.5))
    56         .. K ^TMP($J,"ORCSEND1 SCHEDULE")
    57         .. ;S SCHMX=$P(^PS(51.1,PSJY,0),U,7)
    58         .. S DAYS=$S('SCHMX:LOCMX,LOCMX<SCHMX:LOCMX,1:SCHMX)
    59         .. S PSJFD=$$FMADD^XLFDT(PSJSD,DAYS,,-1)
    60         D ENSPU^PSJEEU K ORY
    61         I ORDUR M ORY=PSJC Q
    62         S ORY=$S(PSJC<$E(ORDUR,2,9):PSJC,1:$E(ORDUR,2,9))
    63         N NXT
    64         S NXT=0 F I=1:1:ORY S NXT=$O(PSJC(NXT)) Q:'NXT  S ORY(NXT)=PSJC(NXT)
    65         Q
    66 GETORDER(IFN)   ; Set ORX(Inst,Ptr)=Value
    67         N I,X,Y,PTR,INST,TYPE
    68         S I=0 F  S I=$O(^OR(100,IFN,4.5,I)) Q:I'>0  S X=$G(^(I,0)),Y=$G(^(1)) D
    69         . S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U)
    70         . I TYPE'="W" S ORX(INST,PTR)=Y Q
    71         . S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)"
    72         Q
    73 PTR(X)  ; Returns ptr of prompt X in Order Dialog file
    74         Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
    75 PS      ; spawn child orders if multiple doses
    76 PSJ     ; (Inpt only)
    77 PSS     ;
    78         N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS
    79         N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM
    80         N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I,ORADMIN
    81         S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3))
    82         Q:$P(OR0,U,12)'="I"  S ORCAT="I",ORNP=+$P(OR0,U,4)
    83         S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7)
    84         S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14)
    85         D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT)
    86         S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE")
    87         S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION")
    88         S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG"))
    89         S ORADMIN=$$PTR("ADMIN TIMES")
    90         D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1
    91         S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG")
    92         S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG")
    93         S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME")
    94         I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D
    95         . S ORENEW=+$P(OR3,U,5),I=0
    96         . I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0))
    97         . F  S I=$O(^OR(100,ORENEW,2,I)) Q:I<1  S ORENEW(I)=""
    98 PS1     F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D
    99         . N PTR S PTR=$$PTR(ORP) Q:PTR'>0  Q:'$D(ORX(1,PTR))
    100         . S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR)
    101         S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D
    102         . F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP)
    103         . S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6)
    104         . S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT
    105         . D SIG,CHILD^ORCSEND3(ORSTART)
    106         F  D  S ORI=$O(ORX(ORI)) Q:ORI'>0
    107         . F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID,ORADMIN S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)
    108         . K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID))
    109         . S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6)
    110         . S ORSTART=$G(ORSTRT(ORI))
    111         . D SIG,CHILD^ORCSEND3(ORSTART)
    112         S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
    113         S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3)
    114         I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders"
    115         D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J)
    116         S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time?
    117         Q:(STS=1)!(STS=13)!(STS=11)  ;unsuccessful
    118 PS2     ; ck if parent is unsigned or edit
    119         I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES
    120         Q:$P(OR3,U,11)'=1  S ORIG=$P(OR3,U,5) Q:ORIG'>0
    121         S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC")
    122         D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D
    123         . N NATR S NATR=+$O(^ORD(100.02,"C","C",0))
    124         . S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW
    125         . D CANCEL^ORCSEND(ORIG) ;ck for unrel actions
    126         Q
    127 DOSES(IFN)      ; count number of doses in order
    128         N I,CNT S CNT=0
    129         S I=0 F  S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0  I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1
    130         S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1
    131         Q CNT
    132 FRSTDOSE()      ; Return instance of first dose
    133         N I,Y S I=0,Y=1
    134         F  S I=$O(ORX(I)) Q:I'>0  I $D(ORX(I,ORDOSE)) S Y=I Q
    135         Q Y
    136 SIG     ; Build text of instructions
    137         N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1)
    138         S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1))
    139         S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1
    140         S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2
    141         S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX
    142         S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1))
    143         S ORDIALOG(ORDOSE,"FORMAT")="@"
    144         K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1)
    145         I ORDRUG,'ID D  ;set strength or drug name
    146         . N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8)
    147         . I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q
    148         . S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U)
    149         . S:ITM'[STR ORDIALOG(ORSTR,1)=STR
    150         Q
    151 STRT    ; Build ORSTRT(inst)=date.time array of start times by dose
    152         N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT
    153         S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM")))
    154         S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0
    155         S ORWD=+$G(^SC(+$G(ORL),42)) ;ward
    156         S ORI=0 F  S ORI=$O(ORX(ORI)) Q:ORI<1  D
    157         . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT
    158         . S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4)
    159         . S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET
    160         . ; update OFFSET for next THEN dose
    161         . D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D
    162         .. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration
    163         .. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I))
    164         .. K ORD
    165         ; find beginning date.time for parent
    166         S ORI=0,X=9999999 F  S ORI=$O(ORSTRT(ORI)) Q:ORI<1  I ORSTRT(ORI)<X S X=ORSTRT(ORI)
    167         S ORSTRT("BEG")=X
    168         Q
    169 DUR(I)  ; Accumulate duration in ORD("Xt") for offsetting next THEN dose
    170         N X,Y S X=$$FMDUR^ORCDPS3($G(ORX(I,ORDUR)))
    171         I X["S",+X>$G(ORD("XS")) S ORD("XS")=+X
    172         I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X
    173         I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X
    174         S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0)
    175         I Y,Y>$G(ORD("XD")) S ORD("XD")=Y
    176         Q
    177 VBEC    ; Spawn VBECS children
    178         D:$L($T(EN^ORCSEND2)) EN^ORCSEND2
    179         Q
     1ORCSEND1 ;SLC/MKB-Release cont ;11/25/02  09:48
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215**;Dec 17, 1997
     3 ;
     4PKGSTUFF(PKG) ; Package code
     5 S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG)
     6 D:$L($T(@PKG)) @PKG
     7 Q
     8LR ; Spawn child orders if continuous schedule
     9 N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS
     10 S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10)
     11 D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D  Q
     12 . N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8)
     13 . D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule
     14 S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11)
     15 D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1
     16 K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1)
     17 S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
     18 S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE")
     19 S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN")
     20 S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY")
     21 S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
     22 S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE")
     23 S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME")
     24LR1 S ORS1=0 F  S ORS1=$O(ORX(ORS1)) Q:ORS1'>0  D
     25 . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance
     26 . S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1))
     27 . S ORS2=0 F  S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0  D
     28 .. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
     29 .. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC")
     30 .. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC")
     31 .. D CHILD()
     32 S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
     33 S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3)
     34 I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders"
     35 D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE))
     36 Q
     37SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule
     38 N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR
     39 S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q
     40 S ORY=1,ORY(PSJSD)="" ;1st occurrance
     41 S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I  Q:'$L($G(PKG))
     42 S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X)
     43 S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX))
     44 I $G(PSJTS)'="C",$G(PSJTS)'="D" Q  ;not continuous or day-of-week
     45 S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I
     46 S ORDUR=$G(^OR(100,+IFN,4.5,+I,1))
     47 S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1)
     48 I 'ORDUR S X=+$E(ORDUR,2,9) D
     49 . I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times
     50 . E  D  ;no freq in minutes --> day of week
     51 .. N DAYS,LOCMX,SCHMX
     52 .. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
     53 .. S SCHMX=$P(^PS(51.1,PSJY,0),U,7)
     54 .. S DAYS=$S('SCHMX:LOCMX,LOCMX<SCHMX:LOCMX,1:SCHMX)
     55 .. S PSJFD=$$FMADD^XLFDT(PSJSD,DAYS,,-1)
     56 D ENSPU^PSJEEU K ORY
     57 I ORDUR M ORY=PSJC Q
     58 S ORY=$S(PSJC<$E(ORDUR,2,9):PSJC,1:$E(ORDUR,2,9))
     59 N NXT
     60 S NXT=0 F I=1:1:ORY S NXT=$O(PSJC(NXT)) Q:'NXT  S ORY(NXT)=PSJC(NXT)
     61 Q
     62GETORDER(IFN) ; Set ORX(Inst,Ptr)=Value
     63 N I,X,Y,PTR,INST,TYPE
     64 S I=0 F  S I=$O(^OR(100,IFN,4.5,I)) Q:I'>0  S X=$G(^(I,0)),Y=$G(^(1)) D
     65 . S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U)
     66 . I TYPE'="W" S ORX(INST,PTR)=Y Q
     67 . S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)"
     68 Q
     69PTR(X) ; Returns ptr of prompt X in Order Dialog file
     70 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
     71CHILD(STRT) ; Create child order, send to package
     72 N ORAPPT
     73 K ORIFN D EN^ORCSAVE Q:'$G(ORIFN)  D STARTDT^ORCSAVE2(ORIFN)
     74 I $G(STRT) D DATES^ORCSAVE2(ORIFN,STRT)
     75 S ORCHLD=+$G(ORCHLD)+1,^OR(100,ORPARENT,2,ORIFN,0)=ORIFN,ORLAST=ORIFN
     76 S ORAPPT=$P($G(^OR(100,ORPARENT,0)),U,18)
     77 S $P(^OR(100,ORIFN,0),U,18)=ORAPPT,$P(^(3),U,9)=ORPARENT
     78 I $G(PKG)="LR" S $P(^OR(100,ORIFN,8,1,0),U,4)=8 K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;signature tracked on parent order only, for Labs
     79 I $G(PKG)?1"PS".E D
     80 . N X0,OLD S X0=$G(^OR(100,ORPARENT,8,1,0))
     81 . I $P(X0,U,4)'=2 D SIGN^ORCSAVE2(ORIFN,+$P(X0,U,5),ORNOW,$P(X0,U,4),1)
     82 . I $D(^OR(100,ORPARENT,9)) M ^OR(100,ORIFN,9)=^OR(100,ORPARENT,9)
     83 . I $G(ORENEW) S OLD=$O(ORENEW(0)) I OLD S $P(^OR(100,OLD,3),U,6)=ORIFN,$P(^OR(100,ORIFN,3),U,5)=OLD,$P(^(3),U,11)=2 K ORENEW(OLD)
     84 D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)),NEW^ORMBLD(ORIFN)
     85 Q
     86PS ; spawn child orders if multiple doses
     87PSJ ; (Inpt only)
     88PSS ;
     89 N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS
     90 N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM
     91 N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I
     92 S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3))
     93 Q:$P(OR0,U,12)'="I"  S ORCAT="I",ORNP=+$P(OR0,U,4)
     94 S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7)
     95 S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14)
     96 D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT)
     97 S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE")
     98 S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION")
     99 S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG"))
     100 D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1
     101 S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG")
     102 S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG")
     103 S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME")
     104 I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D
     105 . S ORENEW=+$P(OR3,U,5),I=0
     106 . I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0))
     107 . F  S I=$O(^OR(100,ORENEW,2,I)) Q:I<1  S ORENEW(I)=""
     108PS1 F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D
     109 . N PTR S PTR=$$PTR(ORP) Q:PTR'>0  Q:'$D(ORX(1,PTR))
     110 . S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR)
     111 S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D
     112 . F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP)
     113 . S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6)
     114 . S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT
     115 . D SIG,CHILD(ORSTART)
     116 F  D  S ORI=$O(ORX(ORI)) Q:ORI'>0
     117 . F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)
     118 . K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID))
     119 . S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6)
     120 . S ORSTART=$G(ORSTRT(ORI))
     121 . D SIG,CHILD(ORSTART)
     122 S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
     123 S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3)
     124 I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders"
     125 D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J)
     126 S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time?
     127 Q:(STS=1)!(STS=13)!(STS=11)  ;unsuccessful
     128PS2 ; ck if parent is unsigned or edit
     129 I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES
     130 Q:$P(OR3,U,11)'=1  S ORIG=$P(OR3,U,5) Q:ORIG'>0
     131 S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC")
     132 D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D
     133 . N NATR S NATR=+$O(^ORD(100.02,"C","C",0))
     134 . S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW
     135 . D CANCEL^ORCSEND(ORIG) ;ck for unrel actions
     136 Q
     137DOSES(IFN) ; count number of doses in order
     138 N I,CNT S CNT=0
     139 S I=0 F  S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0  I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1
     140 S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1
     141 Q CNT
     142FRSTDOSE() ; Return instance of first dose
     143 N I,Y S I=0,Y=1
     144 F  S I=$O(ORX(I)) Q:I'>0  I $D(ORX(I,ORDOSE)) S Y=I Q
     145 Q Y
     146SIG ; Build text of instructions
     147 N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1)
     148 S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1))
     149 S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1
     150 S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2
     151 S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX
     152 S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1))
     153 S ORDIALOG(ORDOSE,"FORMAT")="@"
     154 K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1)
     155 I ORDRUG,'ID D  ;set strength or drug name
     156 . N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8)
     157 . I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q
     158 . S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U)
     159 . S:ITM'[STR ORDIALOG(ORSTR,1)=STR
     160 Q
     161STRT ; Build ORSTRT(inst)=date.time array of start times by dose
     162 N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT
     163 S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM")))
     164 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0
     165 S ORWD=+$G(^SC(+$G(ORL),42)) ;ward
     166 S ORI=0 F  S ORI=$O(ORX(ORI)) Q:ORI<1  D
     167 . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT
     168 . S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4)
     169 . S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET
     170 . ; update OFFSET for next THEN dose
     171 . D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D
     172 .. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration
     173 .. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I))
     174 .. K ORD
     175 ; find beginning date.time for parent
     176 S ORI=0,X=9999999 F  S ORI=$O(ORSTRT(ORI)) Q:ORI<1  I ORSTRT(ORI)<X S X=ORSTRT(ORI)
     177 S ORSTRT("BEG")=X
     178 Q
     179DUR(I) ; Accumulate duration in ORD("Xt") for offsetting next THEN dose
     180 N X,Y S X=$$FMDUR^ORCDPS3($G(ORX(I,ORDUR)))
     181 I X["S",+X>$G(ORD("XS")) S ORD("XS")=+X
     182 I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X
     183 I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X
     184 S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0)
     185 I Y,Y>$G(ORD("XD")) S ORD("XD")=Y
     186 Q
     187VBEC ; Spawn VBECS children
     188 D:$L($T(EN^ORCSEND2)) EN^ORCSEND2
     189 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND1.m

    r613 r623  
    1 ORCXPND1        ; SLC/MKB - Expanded Display cont ; 04/25/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; External References
    5         ;   DBIA  2387  ^LAB(60
    6         ;   DBIA  3420  ^DPT(  file #2
    7         ;   DBIA 10035  ^DPT(  file #2
    8         ;   DBIA 10037  EN^DGRPD
    9         ;   DBIA   700  DIS^DGRPDB
    10         ;   DBIA  2926  RT^GMRCGUIA
    11         ;   DBIA  2925  DT^GMRCSLM2                     ^TMP("GMRCR"
    12         ;   DBIA  2503  RR^LR7OR1                       ^TMP("LRRR"
    13         ;   DBIA  2951  EN1^LR7OSBR                     ^TMP("LRC"
    14         ;   DBIA  2952  EN^LR7OSMZ0
    15         ;   DBIA  2400  OEL^PSOORRL                     ^TMP("PS"
    16         ;   DBIA  2877  EN3^RAO7PC3
    17         ;   DBIA  2877  EN30^RAO7PC3
    18         ;   DBIA  1252  $$OUTPTPR^SDUTL3
    19         ;   DBIA  1252  $$OUTPTTM^SDUTL3
    20         ;   DBIA  2832  RPC^TIUSRV
    21         ;   DBIA 10061  DEM^VADPT
    22         ;   DBIA 10061  KVAR^VADPT
    23         ;   DBIA 10061  OAD^VADPT
    24         ;   DBIA 10103  $$FMTE^XLFDT
    25         ;   DBIA  4408  DISP^DGIBDSP
    26         ;                       
    27 COVER   ; -- Cover Sheet
    28         N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
    29         D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU"
    30         Q
    31 NOTES   ; -- Progress Notes
    32         N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
    33         D RPC^TIUSRV(.ORY,ID)
    34         S I=0 F  S I=$O(@ORY@(I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
    35         K @ORY
    36         Q
    37 PROBLEMS        ; -- Problem List
    38         D PL^ORCXPND4
    39         Q
    40 MEDS    ; -- Pharmacy
    41         ;N NODE,ORIFN
    42         K ^TMP("PS",$J)
    43         D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11)
    44         S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS  ;DBIA 2400
    45         ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2")
    46         K ^TMP("PS",$J)
    47         Q
    48 LABS    ; -- Laboratory [RESULTS ONLY for ID=OE order #]
    49         N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT
    50         K ^TMP("LRRR",$J)  ;DBIA 2503
    51         I (ID?2.5U1" "2N1" "1.N1"-"7N1"."1.4N)!(ID?2.5U1" "2N1" "1.N1"-"7N) D AP^ORCXPND3 Q  ;ID=Accession #-Date/time specimen taken
    52         S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE)  ; OE# -> Lab#
    53         I +IDE  D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63
    54         I '+IDE,$P(IDE,";",5)  D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4))
    55         K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80)
    56         S IG=0 F  S IG=$O(ORCY(IG)) Q:IG<1  S X=ORCY(IG) D ITEM^ORCXPND(X)
    57         D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
    58         M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS=""
    59         F  S SS=$O(TEST(SS)) Q:SS=""  S IVDT=0 F  S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT  D
    60         . I SS="BB" D
    61         .. I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D  Q  ;Transition to VBEC's interface
    62         ... K ^TMP("ORLRC",$J)
    63         ... D EN^ORWLR1(DFN)
    64         ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
    65         ... N I S I=0 F  S I=$O(^TMP("ORLRC",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
    66         ... K ^TMP("ORLRC",$J)
    67         .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J))  D  Q  ;DBIA 2951
    68         ... N I S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
    69         ... K ^TMP("LRC",$J)
    70         . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J))  D  Q
    71         .. N I S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
    72         .. K ^TMP("LRC",$J)
    73         . I SS="CH" D  Q
    74         .. S (TCNT,TST)=0 F  S TST=$O(TEST(SS,IVDT,TST)) Q:TST=""  S CCNT=0,TCNT=TCNT+1 D
    75         ... I TCNT=1 D
    76         .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="   Collection time:          "_$$FMTE^XLFDT(9999999-IVDT,1)
    77         .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
    78         ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D
    79         .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15))
    80         .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
    81         .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
    82         ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D
    83         .... N CMT S CMT=0 F  S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT)
    84         K ^TMP("LRRR",$J)
    85         Q
    86         ;
    87 DELAY   ; -- Delayed Orders
    88 NEW     ; -- New Orders
    89 ORDERS  ; -- Orders
    90         I '$G(ORESULTS) D ORDERS^ORCXPND2 Q
    91         ; -- Results Display (Add more packages as available)
    92         N PKG,TAB,ORIFN
    93         S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG)
    94         S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
    95         I '$L(TAB)!(ID'>0) D  Q  ; no display available
    96         . N ORY,I D TEXT^ORQ12(.ORY,+ID,80)
    97         . S I=0 F  S I=$O(ORY(I)) Q:I'>0  D ITEM^ORCXPND(ORY(I))
    98         . D BLANK^ORCXPND
    99         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report."
    100         I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F  S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1  I $D(^OR(100,ID,0)) D @TAB
    101         I '$O(^OR(100,+ID,2,0)) D @TAB
    102         Q
    103 REPORTS ; -- Patient Profiles
    104         D EN^ORCXPNDR ; Reports
    105         Q
    106 CONSULTS        ; -- Consults
    107         N I,X,SUB,ORTX ;,VALMAR
    108         I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
    109         E  D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order#
    110         D ITEM^ORCXPND(X),BLANK^ORCXPND
    111         I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
    112         I '$G(ORESULTS) D  ;DT action
    113         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.:           "_ID
    114         . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT"  ;DBIA 2925
    115         I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT"
    116         S I=0 F  S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0  S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X  ;DBIA 2925
    117         K ^TMP("GMRCR",$J)
    118         Q
    119 XRAYS   ; -- Radiology
    120         I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID)
    121         I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID)
    122         N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET"))
    123         S CASE=0 F  S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0  D
    124         . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q
    125         . S PROC="" F  S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC=""  D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND
    126         I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report
    127         K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W")
    128         S VALM("RM")=81
    129         Q
    130         ;
    131 XRPT    ; -- Body of Report for CASE, PROC
    132         N ORD,X,I
    133         S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD
    134         S I=1 F  S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0  S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1
    135         Q
    136         ;
    137 SUMMRIES        ; -- Discharge Summaries
    138         N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
    139         D RPC^TIUSRV(.ORY,ID)
    140         S I=0 F  S I=$O(@ORY@(I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
    141         K @ORY
    142         Q
    143 PTINQ   ; Print Patient Inquiry in List Manager
    144         N DFN,ORI,X
    145         S DFN=+ORVP
    146         D DGINQ(DFN)
    147         S ORI=4,LCNT=0
    148         F  S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI  S X=^(ORI) D
    149         . S LCNT=LCNT+1
    150         . S ^TMP("ORXPND",$J,LCNT,0)=X
    151         K ^TMP("ORDATA",$J,1)
    152         Q
    153         ;
    154 DGINQ(DFN)      ; Patient Inquiry
    155         D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
    156         Q
    157 DGINQB(DFN)     ; Build Patient Inquiry
    158         N CONTACT,ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA
    159         S ORVP=DFN_";DPT(",XQORNOD=1
    160         D EN^DGRPD ; MAS Patient Inquiry
    161         ;
    162         S ORDOC=$$OUTPTPR^SDUTL3(DFN)
    163         S ORTEAM=$$OUTPTTM^SDUTL3(DFN)
    164         I ORDOC!ORTEAM  D
    165         . W !!,"Primary Care Information:"
    166         . I ORDOC W !,"Primary Practitioner:  ",$P(ORDOC,"^",2)
    167         . I ORTEAM W !,"Primary Care Team:     ",$P(ORTEAM,"^",2)
    168         W !!,"Health Insurance Information:"
    169         D DISP^DGIBDSP  ;DBIA #4408
    170         W !!,"Service Connection/Rated Disabilities:"
    171         D DIS^DGRPDB
    172         F CONTACT="N","S" D
    173         .S VAOA("A")=$S(CONTACT="N":"",1:3)
    174         .D OAD^VADPT ;   Get NOK Information
    175         .I VAOA(9)]"" D
    176         .. W !!,$S(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:")
    177         .. W !,"Name:  ",VAOA(9)                          ;     NOK Name
    178         .. I VAOA(10)]"" W " (",VAOA(10),")"              ;     Relationship
    179         .. I VAOA(1)]"" W !?7,VAOA(1)                     ;     Address Line 1
    180         .. I VAOA(2)]"" W !?7,VAOA(2)                     ;     Line 2
    181         .. I VAOA(3)]"" W !?7,VAOA(3)                     ;     Line 3
    182         .. I VAOA(4)]"" D
    183         .. . W !?7,VAOA(4)                                ;     City
    184         .. . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2)        ;     State
    185         .. . W "  ",$P(VAOA(11),"^",2)                    ;     Zip+4
    186         .. I VAOA(8)]"" W !!?7,"Phone number:  ",VAOA(8)  ;     Phone
    187         .. I CONTACT="N",$P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number:  ",$P(^DPT(DFN,.21),U,11)
    188         .. I CONTACT="S",$P($G(^DPT(DFN,.211)),U,11)]"" W !?7,"Work phone number:  ",$P(^DPT(DFN,.211),U,11)
    189         D KVAR^VADPT
    190         Q
    191 TRIM(X) ;   Trim Spaces
    192         S X=$G(X) F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
    193         F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,($L(X)-1))
    194         Q X
    195 S(X,Y,Z)        ; Pad Over
    196         ;   X=Column #
    197         ;   Y=Current Length
    198         ;   Z=Text
    199         ;   SP=Text Sent
    200         ;   CCNT=Line Position After Input Text
    201         I '$D(Z) Q ""
    202         N SP S SP=Z I X,Y,X>Y S SP=$E("                                                                             ",1,X-Y)_Z
    203         S CCNT=$$INC(CCNT,SP)
    204         Q SP
    205 INC(X,Y)        ; Character Position Count
    206         ;   X=Current Count
    207         ;   Y=Text
    208         N INC S INC=X+$L(Y)
    209         Q INC
     1ORCXPND1 ; SLC/MKB - Expanded Display cont ; 02/20/2003
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215**;Dec 17, 1997
     3 ;
     4 ; External References
     5 ;   DBIA  2387  ^LAB(60
     6 ;   DBIA  3420  ^DPT(  file #2
     7 ;   DBIA 10035  ^DPT(  file #2
     8 ;   DBIA 10037  EN^DGRPD
     9 ;   DBIA   700  DIS^DGRPDB
     10 ;   DBIA  2926  RT^GMRCGUIA
     11 ;   DBIA  2925  DT^GMRCSLM2                     ^TMP("GMRCR"
     12 ;   DBIA 10146  DISP^IBCNS
     13 ;   DBIA  2503  RR^LR7OR1                       ^TMP("LRRR"
     14 ;   DBIA  2951  EN1^LR7OSBR                     ^TMP("LRC"
     15 ;   DBIA  2952  EN^LR7OSMZ0
     16 ;   DBIA  2400  OEL^PSOORRL                     ^TMP("PS"
     17 ;   DBIA  2877  EN3^RAO7PC3
     18 ;   DBIA  2877  EN30^RAO7PC3
     19 ;   DBIA  1252  $$OUTPTPR^SDUTL3
     20 ;   DBIA  1252  $$OUTPTTM^SDUTL3
     21 ;   DBIA  2832  RPC^TIUSRV
     22 ;   DBIA 10061  DEM^VADPT
     23 ;   DBIA 10061  KVAR^VADPT
     24 ;   DBIA 10061  OAD^VADPT
     25 ;   DBIA 10103  $$FMTE^XLFDT
     26 ;   DBIA  4408  DISP^DGIBDSP
     27 ;                       
     28COVER ; -- Cover Sheet
     29 N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
     30 D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU"
     31 Q
     32NOTES ; -- Progress Notes
     33 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
     34 D RPC^TIUSRV(.ORY,ID)
     35 S I=0 F  S I=$O(@ORY@(I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
     36 K @ORY
     37 Q
     38PROBLEMS ; -- Problem List
     39 D PL^ORCXPND4
     40 Q
     41MEDS ; -- Pharmacy
     42 ;N NODE,ORIFN
     43 D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11)
     44 S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS  ;DBIA 2400
     45 ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2")
     46 K ^TMP("PS",$J)
     47 Q
     48LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #]
     49 N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT
     50 K ^TMP("LRRR",$J)  ;DBIA 2503
     51 S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE)  ; OE# -> Lab#
     52 I +IDE  D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63
     53 I '+IDE,$P(IDE,";",5)  D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4))
     54 K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80)
     55 S IG=0 F  S IG=$O(ORCY(IG)) Q:IG<1  S X=ORCY(IG) D ITEM^ORCXPND(X)
     56 D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
     57 M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS=""
     58 F  S SS=$O(TEST(SS)) Q:SS=""  S IVDT=0 F  S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT  D
     59 . I SS="BB" D
     60 .. I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D  Q  ;Transition to VBEC's interface
     61 ... K ^TMP("ORLRC",$J)
     62 ... D EN^ORWLR1(DFN)
     63 ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
     64 ... N I S I=0 F  S I=$O(^TMP("ORLRC",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
     65 ... K ^TMP("ORLRC",$J)
     66 .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J))  D  Q  ;DBIA 2951
     67 ... N I S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
     68 ... K ^TMP("LRC",$J)
     69 . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J))  D  Q
     70 .. N I S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
     71 .. K ^TMP("LRC",$J)
     72 . I SS="CH" D  Q
     73 .. S (TCNT,TST)=0 F  S TST=$O(TEST(SS,IVDT,TST)) Q:TST=""  S CCNT=0,TCNT=TCNT+1 D
     74 ... I TCNT=1 D
     75 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="   Collection time:          "_$$FMTE^XLFDT(9999999-IVDT,1)
     76 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
     77 ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D
     78 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15))
     79 .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
     80 .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
     81 ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D
     82 .... N CMT S CMT=0 F  S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT)
     83 K ^TMP("LRRR",$J)
     84 Q
     85 ;
     86DELAY ; -- Delayed Orders
     87NEW ; -- New Orders
     88ORDERS ; -- Orders
     89 I '$G(ORESULTS) D ORDERS^ORCXPND2 Q
     90 ; -- Results Display (Add more packages as available)
     91 N PKG,TAB,ORIFN
     92 S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG)
     93 S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
     94 I '$L(TAB)!(ID'>0) D  Q  ; no display available
     95 . N ORY,I D TEXT^ORQ12(.ORY,+ID,80)
     96 . S I=0 F  S I=$O(ORY(I)) Q:I'>0  D ITEM^ORCXPND(ORY(I))
     97 . D BLANK^ORCXPND
     98 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report."
     99 I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F  S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1  I $D(^OR(100,ID,0)) D @TAB
     100 I '$O(^OR(100,+ID,2,0)) D @TAB
     101 Q
     102REPORTS ; -- Patient Profiles
     103 D EN^ORCXPNDR ; Reports
     104 Q
     105CONSULTS ; -- Consults
     106 N I,X,SUB,ORTX ;,VALMAR
     107 I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
     108 E  D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order#
     109 D ITEM^ORCXPND(X),BLANK^ORCXPND
     110 I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
     111 I '$G(ORESULTS) D  ;DT action
     112 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.:           "_ID
     113 . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT"  ;DBIA 2925
     114 I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT"
     115 S I=0 F  S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0  S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X  ;DBIA 2925
     116 K ^TMP("GMRCR",$J)
     117 Q
     118XRAYS ; -- Radiology
     119 I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID)
     120 I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID)
     121 N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET"))
     122 S CASE=0 F  S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0  D
     123 . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q
     124 . S PROC="" F  S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC=""  D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND
     125 I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report
     126 K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W")
     127 S VALM("RM")=81
     128 Q
     129 ;
     130XRPT ; -- Body of Report for CASE, PROC
     131 N ORD,X,I
     132 S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD
     133 S I=1 F  S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0  S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1
     134 Q
     135 ;
     136SUMMRIES ; -- Discharge Summaries
     137 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
     138 D RPC^TIUSRV(.ORY,ID)
     139 S I=0 F  S I=$O(@ORY@(I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
     140 K @ORY
     141 Q
     142PTINQ ; Print Patient Inquiry in List Manager
     143 N DFN,ORI,X
     144 S DFN=+ORVP
     145 D DGINQ(DFN)
     146 S ORI=4,LCNT=0
     147 F  S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI  S X=^(ORI) D
     148 . S LCNT=LCNT+1
     149 . S ^TMP("ORXPND",$J,LCNT,0)=X
     150 K ^TMP("ORDATA",$J,1)
     151 Q
     152 ;
     153DGINQ(DFN) ; Patient Inquiry
     154 D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
     155 Q
     156DGINQB(DFN) ; Build Patient Inquiry
     157 N ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOP,X,VAOA
     158 S ORVP=DFN_";DPT(",XQORNOD=1
     159 D EN^DGRPD ; MAS Patient Inquiry
     160 ;
     161 S ORDOC=$$OUTPTPR^SDUTL3(DFN)
     162 S ORTEAM=$$OUTPTTM^SDUTL3(DFN)
     163 I ORDOC!ORTEAM  D
     164 . W !!,"Primary Care Information:"
     165 . I ORDOC W !,"Primary Practitioner:  ",$P(ORDOC,"^",2)
     166 . I ORTEAM W !,"Primary Care Team:     ",$P(ORTEAM,"^",2)
     167 W !!,"Health Insurance Information:"
     168 I $L($T(DISP^DGIBDSP)) D DISP^DGIBDSP  ;DBIA #4408
     169 E  D DISP^IBCNS
     170 W !!,"Service Connection/Rated Disabilities:"
     171 D DIS^DGRPDB
     172 D OAD^VADPT ;   Get NOK Information
     173 I VAOA(9)]"" D
     174 . W !!,"Next of Kin Information:"
     175 . W !,"Name:  ",VAOA(9)                          ;     NOK Name
     176 . I VAOA(10)]"" W " (",VAOA(10),")"              ;     Relationship
     177 . I VAOA(1)]"" W !?7,VAOA(1)                     ;     Address Line 1
     178 . I VAOA(2)]"" W !?7,VAOA(2)                     ;     Line 2
     179 . I VAOA(3)]"" W !?7,VAOA(3)                     ;     Line 3
     180 . I VAOA(4)]"" D
     181 . . W !?7,VAOA(4)                                ;     City
     182 . . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2)        ;     State
     183 . . W "  ",$P(VAOA(11),"^",2)                    ;     Zip+4
     184 . I VAOA(8)]"" W !!?7,"Phone number:  ",VAOA(8)  ;     Phone
     185 . I $P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number:  ",$P(^DPT(DFN,.21),U,11)
     186 D KVAR^VADPT
     187 Q
     188TRIM(X) ;   Trim Spaces
     189 S X=$G(X) F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
     190 F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,($L(X)-1))
     191 Q X
     192S(X,Y,Z) ; Pad Over
     193 ;   X=Column #
     194 ;   Y=Current Length
     195 ;   Z=Text
     196 ;   SP=Text Sent
     197 ;   CCNT=Line Position After Input Text
     198 I '$D(Z) Q ""
     199 N SP S SP=Z I X,Y,X>Y S SP=$E("                                                                             ",1,X-Y)_Z
     200 S CCNT=$$INC(CCNT,SP)
     201 Q SP
     202INC(X,Y) ; Character Position Count
     203 ;   X=Current Count
     204 ;   Y=Text
     205 N INC S INC=X+$L(Y)
     206 Q INC

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND3.m

    r613 r623  
    1 ORCXPND3        ; SLC/MKB,dcm - Expanded display of Reports ;2/21/01  14:07
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,30,43,85,172,243**;Dec 17, 1997;Build 242
    3         ;
    4 AP      ; -- Retrieve AP results for a specific date/time specimen taken
    5         ; [alert follow-up, from LABS^ORCXPND1]
    6         N ORACCNO,ORDTSTKN S ORACCNO=$P(ID,"-"),ORDTSTKN=$P(ID,"-",2)
    7         I (ORACCNO["CY"!(ORACCNO["SP")!(ORACCNO["EM")!(ORACCNO["AU"))&($L(ORACCNO)>0) D  ;check for valid accession #
    8         . N ORLRDFN,ORLRSS S ORLRDFN=$$LRDFN^LR7OR1(DFN),ORLRSS=$P($G(XQADATA),U) ;DBIA/ICR #2503
    9         . K ^TMP("ORAP",$J) D EN^LR7OSAP4("^TMP(""ORAP"",$J)",ORLRDFN,ORLRSS,ORDTSTKN)
    10         . I '$O(^TMP("ORAP",$J,0)) S ^TMP("ORAP",$J,1,0)="",^TMP("ORAP",$J,2,0)="No Anatomic Pathology report available..."
    11         . N I S I=0 F  S I=$O(^TMP("ORAP",$J,I)) Q:I<1  S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
    12         . K ^TMP("ORAP",$J)
    13         Q
    14         ;
    15 LRA     ; -- Anatomic Pathology Report
    16         N DFN,Y,I,LRLLOC,LRQ
    17         D TIT^ORCXPNDR("Anatomic Path Report") Q:$$OS^ORCXPNDR()
    18         D PREP^ORCXPNDR
    19         D RPT^ORWRP(.Y,ID,3)
    20         D ITEM^ORCXPND("Anatomic Path Report")
    21         S I=3 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I)
    22         K ^TMP("ORDATA",$J)
    23         Q
    24         ;
    25 LRAA    ; -- Alternate Anatomic Path Report
    26         N DFN,Y,I,LRLLOC,LRQ
    27         D TIT^ORCXPNDR("Alternate Anatomic Path Report") Q:$$OS^ORCXPNDR()
    28         D PREP^ORCXPNDR I $$OS^ORCXPNDR() Q
    29         D AP^LR7OSUM(ID)
    30         D ITEM^ORCXPND("Anatomic Pathology Report")
    31         I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Anatomic Pathology reports available..."
    32         S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0)
    33         K ^TMP("LRC",$J)
    34         Q
    35         ;
    36 LRB1    ; -- Blood Bank Report
    37         N DFN,Y,I,LRBLOOD,LRCAPA,LRDT0,LRLABKY,LRLLOC,LRO,LRPCEVSO,LRPLASMA,LRSERUM,LRT,LRUNKNOW,LRURINE,LRVIDO,LRVIDOF
    38         D TIT^ORCXPNDR("Blood Bank Report") Q:$$OS^ORCXPNDR()
    39         D PREP^ORCXPNDR
    40         D RPT^ORWRP(.Y,ID,2)
    41         D ITEM^ORCXPND("Blood Bank Report")
    42         S I=5 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I)
    43         K ^TMP("ORDATA",$J)
    44         Q
    45         ;
    46 LRB     ; -- A better Blood Bank Report
    47         N DFN,ORY,I,SUBHEAD
    48         D TIT^ORCXPNDR("Blood Bank Report")
    49         S DFN=ID
    50         D PREP^ORCXPNDR
    51         I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D  Q  ;Transition to VBEC's interface
    52         . K ^TMP("ORLRC",$J)
    53         . D EN^ORWLR1(DFN)
    54         . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
    55         . D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND
    56         . S I=0 F  S I=$O(^TMP("ORLRC",$J,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORLRC",$J,I,0)
    57         . K ^TMP("ORLRC",$J)
    58         S SUBHEAD("BLOOD BANK")=""
    59         D EN^LR7OSUM(.ORY,DFN,,,,,.SUBHEAD)
    60         I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Blood Bank report available..."
    61         D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND
    62         S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0)
    63         K ^TMP("LRC",$J),^TMP("LRH",$J)
    64         Q
    65         ;
    66 LRC     ; -- Lab Cumulative
    67         N DFN,ORY,I,BEG,END,OREND,ORSSTRT,ORSSTOP
    68         D TIT^ORCXPNDR("Lab Cumulative")
    69         S DFN=ID
    70         D RANGE($S($G(ORWARD):7,1:180)) Q:OREND  S BEG=+ORSSTRT,END=+ORSSTOP
    71         D PREP^ORCXPNDR
    72         D EN^LR7OSUM(.ORY,DFN,BEG,END)
    73         D ITEM^ORCXPND("Lab Cumulative"),BLANK^ORCXPND
    74         S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0)
    75         K ^TMP("LRC",$J),^TMP("LRH",$J)
    76         Q
    77         ;
    78 LRG     ; -- Graph Lab Tests
    79         N DFN,Y,I,X,BCNT,LRSS,LRCW,LRFLAG,LRCTRL,LRNSET,N,LOW,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP
    80         D TIT^ORCXPNDR("Graph Lab Tests") Q:$$OS^ORCXPNDR()
    81         D RANGE($S($G(ORWARD):7,1:180)) Q:OREND
    82         S LRSS="CH",LRCW=8,LRFLAG="",LRCTRL=0,(LRNSET,N)=80
    83         D L2^LRDIST4 Q:'$D(LRTEST)
    84         D PREP^ORCXPNDR
    85         D RPT^ORWRP(.Y,ID,8,,,,+ORSSTRT,+ORSSTOP)
    86         D ITEM^ORCXPND("Lab Graph")
    87         S I=4,BCNT=0
    88         F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
    89         . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
    90         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
    91         K ^TMP("ORDATA",$J)
    92         Q
    93         ;
    94 LRI     ; -- Interim Lab Results
    95         N ORX,DFN,Y,I,X,BCNT,LREDT,LRIDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP
    96         D TIT^ORCXPNDR("Lab Interim Results") Q:$$OS^ORCXPNDR()
    97         D RANGE($S($G(ORWARD):7,1:180)) Q:OREND
    98         D SET^LRRP4
    99         D PREP^ORCXPNDR
    100         D RPT^ORWRP(.Y,ID,3,,,,+ORSSTRT,+ORSSTOP)
    101         D ITEM^ORCXPND("Lab Interim Report")
    102         S I=0,BCNT=0
    103         F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
    104         . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
    105         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
    106         K ^TMP("ORDATA",$J)
    107         Q
    108         ;
    109 LRGEN   ;Lab Results by Test
    110         N DFN,Y,I,II,X,BCNT,LRPRETTY,LREDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,LRCW,LREND,LRTP,LRIX,LRWPL,LRIDT,LRSC,DIC,LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRSSP,LRHI,LRLO
    111         N LBL,LRBLOOD,LRDAT,LRDFN,LRDPF,LRDT0,LREX,LRFFLG,LRFOOT,LRLAB,LRLABKY,LRND,LRNG,LRNOP,LRNOTE,LRODT0,LRONESPC,LRONETST,LRPAGE,LRPARAM,LRPLASMA,LRPP,LRSERUM,LRPS,LRTN,LRUNKNOW,LRURINE,LRWRD,LRX,LRY
    112         N AGE,I,INC,LRIDT1,LRSV,OREND,ORSSTRT,ORSSTOP
    113         K ^TMP("LR",$J)
    114         D TIT^ORCXPNDR("Lab Results by Test") Q:$$OS^ORCXPNDR()
    115         D RANGE($S($G(ORWARD):7,1:180)) Q:OREND
    116         D SET^LRGEN
    117         Q:LREND!'LRTSTS
    118         D PREP^ORCXPNDR
    119         D RPT^ORWRP(.Y,ID,16,,,,+ORSSTRT,+ORSSTOP)
    120         D ITEM^ORCXPND("Lab Results by Test")
    121         S I=1,BCNT=0
    122         F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
    123         . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
    124         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
    125         K ^TMP("ORDATA",$J)
    126         Q
    127         ;
    128 STAT    ; -- Lab test status
    129         N DFN,Y,I,X,BCNT,OREND,ORSSTRT,ORSSTOP
    130         D TIT^ORCXPNDR("Lab Test Status") Q:$$OS^ORCXPNDR()
    131         D RANGE($S($G(ORWARD):7,1:180)) Q:$G(OREND)
    132         D PREP^ORCXPNDR
    133         D RPT^ORWRP(.Y,ID,9,,,,+ORSSTRT,+ORSSTOP)
    134         D ITEM^ORCXPND("Lab Test Status")
    135         S I=0,BCNT=0
    136         F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=$S($D(^(I))#2:^(I),$D(^(I,0))#2:^(0),1:"") D
    137         . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
    138         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
    139         K ^TMP("ORDATA",$J)
    140         Q
    141         ;
    142 RANGE(BEG)      ;Get date range for report
    143         ;BEG=# of days (T-BEG) for start default
    144         ;Output: ORSSTRT=Start date/time
    145         ;        ORSSTOP=Stop date/time
    146         ;        OREND=1 if user '^'s out, so look for it!
    147         S BEG=$$FMADD^XLFDT(DT,-$G(BEG)),END=$$NOW^XLFDT
    148         D RANGE^ORPRS01(BEG,END)
    149         Q
    150         ;
    151 MED(MED)        ; -- Medicine Summary of Patient Procedures
    152         N DFN,Y,I,X,BCNT,OREND,PROCID
    153         D TIT^ORCXPNDR("Summary of Patient Procedures") Q:$$OS^ORCXPNDR()
    154         D PREP^ORCXPNDR
    155         S DFN=+ID,PROCID=$P(MED,"~",2)
    156         D RPT^ORWRP(.Y,DFN,19,,,PROCID)
    157         D ITEM^ORCXPND("Summary of Patient Procedures")
    158         S I=4,BCNT=0
    159         F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
    160         . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
    161         . I $E(X,1,4)="Pg. " Q
    162         . I X["PHYSICIANS' SIGNATURE" Q
    163         . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
    164         K ^TMP("ORDATA",$J)
    165         Q
     1ORCXPND3 ; SLC/MKB,dcm - Expanded display of Reports ;2/21/01  14:07
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,30,43,85,172**;Dec 17, 1997
     3LRA ; -- Anatomic Pathology Report
     4 N DFN,Y,I,LRLLOC,LRQ
     5 D TIT^ORCXPNDR("Anatomic Path Report") Q:$$OS^ORCXPNDR()
     6 D PREP^ORCXPNDR
     7 D RPT^ORWRP(.Y,ID,3)
     8 D ITEM^ORCXPND("Anatomic Path Report")
     9 S I=3 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I)
     10 K ^TMP("ORDATA",$J)
     11 Q
     12 ;
     13LRAA ; -- Alternate Anatomic Path Report
     14 N DFN,Y,I,LRLLOC,LRQ
     15 D TIT^ORCXPNDR("Alternate Anatomic Path Report") Q:$$OS^ORCXPNDR()
     16 D PREP^ORCXPNDR I $$OS^ORCXPNDR() Q
     17 D AP^LR7OSUM(ID)
     18 D ITEM^ORCXPND("Anatomic Pathology Report")
     19 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Anatomic Pathology reports available..."
     20 S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0)
     21 K ^TMP("LRC",$J)
     22 Q
     23LRB1 ; -- Blood Bank Report
     24 N DFN,Y,I,LRBLOOD,LRCAPA,LRDT0,LRLABKY,LRLLOC,LRO,LRPCEVSO,LRPLASMA,LRSERUM,LRT,LRUNKNOW,LRURINE,LRVIDO,LRVIDOF
     25 D TIT^ORCXPNDR("Blood Bank Report") Q:$$OS^ORCXPNDR()
     26 D PREP^ORCXPNDR
     27 D RPT^ORWRP(.Y,ID,2)
     28 D ITEM^ORCXPND("Blood Bank Report")
     29 S I=5 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I)
     30 K ^TMP("ORDATA",$J)
     31 Q
     32 ;
     33LRB ; -- A better Blood Bank Report
     34 N DFN,ORY,I,SUBHEAD
     35 D TIT^ORCXPNDR("Blood Bank Report")
     36 S DFN=ID
     37 D PREP^ORCXPNDR
     38 I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D  Q  ;Transition to VBEC's interface
     39 . K ^TMP("ORLRC",$J)
     40 . D EN^ORWLR1(DFN)
     41 . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
     42 . D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND
     43 . S I=0 F  S I=$O(^TMP("ORLRC",$J,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORLRC",$J,I,0)
     44 . K ^TMP("ORLRC",$J)
     45 S SUBHEAD("BLOOD BANK")=""
     46 D EN^LR7OSUM(.ORY,DFN,,,,,.SUBHEAD)
     47 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Blood Bank report available..."
     48 D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND
     49 S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0)
     50 K ^TMP("LRC",$J),^TMP("LRH",$J)
     51 Q
     52LRC ; -- Lab Cumulative
     53 N DFN,ORY,I,BEG,END,OREND,ORSSTRT,ORSSTOP
     54 D TIT^ORCXPNDR("Lab Cumulative")
     55 S DFN=ID
     56 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND  S BEG=+ORSSTRT,END=+ORSSTOP
     57 D PREP^ORCXPNDR
     58 D EN^LR7OSUM(.ORY,DFN,BEG,END)
     59 D ITEM^ORCXPND("Lab Cumulative"),BLANK^ORCXPND
     60 S I=0 F  S I=$O(^TMP("LRC",$J,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0)
     61 K ^TMP("LRC",$J),^TMP("LRH",$J)
     62 Q
     63 ;
     64LRG ; -- Graph Lab Tests
     65 N DFN,Y,I,X,BCNT,LRSS,LRCW,LRFLAG,LRCTRL,LRNSET,N,LOW,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP
     66 D TIT^ORCXPNDR("Graph Lab Tests") Q:$$OS^ORCXPNDR()
     67 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND
     68 S LRSS="CH",LRCW=8,LRFLAG="",LRCTRL=0,(LRNSET,N)=80
     69 D L2^LRDIST4 Q:'$D(LRTEST)
     70 D PREP^ORCXPNDR
     71 D RPT^ORWRP(.Y,ID,8,,,,+ORSSTRT,+ORSSTOP)
     72 D ITEM^ORCXPND("Lab Graph")
     73 S I=4,BCNT=0
     74 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
     75 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
     76 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
     77 K ^TMP("ORDATA",$J)
     78 Q
     79 ;
     80LRI ; -- Interim Lab Results
     81 N ORX,DFN,Y,I,X,BCNT,LREDT,LRIDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP
     82 D TIT^ORCXPNDR("Lab Interim Results") Q:$$OS^ORCXPNDR()
     83 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND
     84 D SET^LRRP4
     85 D PREP^ORCXPNDR
     86 D RPT^ORWRP(.Y,ID,3,,,,+ORSSTRT,+ORSSTOP)
     87 D ITEM^ORCXPND("Lab Interim Report")
     88 S I=0,BCNT=0
     89 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
     90 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
     91 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
     92 K ^TMP("ORDATA",$J)
     93 Q
     94LRGEN ;Lab Results by Test
     95 N DFN,Y,I,II,X,BCNT,LRPRETTY,LREDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,LRCW,LREND,LRTP,LRIX,LRWPL,LRIDT,LRSC,DIC,LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRSSP,LRHI,LRLO
     96 N LBL,LRBLOOD,LRDAT,LRDFN,LRDPF,LRDT0,LREX,LRFFLG,LRFOOT,LRLAB,LRLABKY,LRND,LRNG,LRNOP,LRNOTE,LRODT0,LRONESPC,LRONETST,LRPAGE,LRPARAM,LRPLASMA,LRPP,LRSERUM,LRPS,LRTN,LRUNKNOW,LRURINE,LRWRD,LRX,LRY
     97 N AGE,I,INC,LRIDT1,LRSV,OREND,ORSSTRT,ORSSTOP
     98 K ^TMP("LR",$J)
     99 D TIT^ORCXPNDR("Lab Results by Test") Q:$$OS^ORCXPNDR()
     100 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND
     101 D SET^LRGEN
     102 Q:LREND!'LRTSTS
     103 D PREP^ORCXPNDR
     104 D RPT^ORWRP(.Y,ID,16,,,,+ORSSTRT,+ORSSTOP)
     105 D ITEM^ORCXPND("Lab Results by Test")
     106 S I=1,BCNT=0
     107 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
     108 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
     109 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
     110 K ^TMP("ORDATA",$J)
     111 Q
     112 ;
     113STAT ; -- Lab test status
     114 N DFN,Y,I,X,BCNT,OREND,ORSSTRT,ORSSTOP
     115 D TIT^ORCXPNDR("Lab Test Status") Q:$$OS^ORCXPNDR()
     116 D RANGE($S($G(ORWARD):7,1:180)) Q:$G(OREND)
     117 D PREP^ORCXPNDR
     118 D RPT^ORWRP(.Y,ID,9,,,,+ORSSTRT,+ORSSTOP)
     119 D ITEM^ORCXPND("Lab Test Status")
     120 S I=0,BCNT=0
     121 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=$S($D(^(I))#2:^(I),$D(^(I,0))#2:^(0),1:"") D
     122 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
     123 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
     124 K ^TMP("ORDATA",$J)
     125 Q
     126RANGE(BEG) ;Get date range for report
     127 ;BEG=# of days (T-BEG) for start default
     128 ;Output: ORSSTRT=Start date/time
     129 ;        ORSSTOP=Stop date/time
     130 ;        OREND=1 if user '^'s out, so look for it!
     131 S BEG=$$FMADD^XLFDT(DT,-$G(BEG)),END=$$NOW^XLFDT
     132 D RANGE^ORPRS01(BEG,END)
     133 Q
     134MED(MED) ; -- Medicine Summary of Patient Procedures
     135 N DFN,Y,I,X,BCNT,OREND,PROCID
     136 D TIT^ORCXPNDR("Summary of Patient Procedures") Q:$$OS^ORCXPNDR()
     137 D PREP^ORCXPNDR
     138 S DFN=+ID,PROCID=$P(MED,"~",2)
     139 D RPT^ORWRP(.Y,DFN,19,,,PROCID)
     140 D ITEM^ORCXPND("Summary of Patient Procedures")
     141 S I=4,BCNT=0
     142 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1  S X=^(I) D
     143 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q
     144 . I $E(X,1,4)="Pg. " Q
     145 . I X["PHYSICIANS' SIGNATURE" Q
     146 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0
     147 K ^TMP("ORDATA",$J)
     148 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m

    r613 r623  
    1 ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 11/08/09
     1ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 12/25/06
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m

    r613 r623  
    1 ORD21 ; COMPILED XREF FOR FILE #100 ; 11/08/09
     1ORD21 ; COMPILED XREF FOR FILE #100 ; 12/25/06
    22 ;
    33 S DIKZK=2

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m

    r613 r623  
    1 ORD210 ; COMPILED XREF FOR FILE #100.001 ; 11/08/09
     1ORD210 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06
    22 ;
    33 S DA(1)=DA S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m

    r613 r623  
    1 ORD211 ; COMPILED XREF FOR FILE #100.002 ; 11/08/09
     1ORD211 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m

    r613 r623  
    1 ORD212 ; COMPILED XREF FOR FILE #100.008 ; 11/08/09
     1ORD212 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m

    r613 r623  
    1 ORD213 ; COMPILED XREF FOR FILE #100.04 ; 11/08/09
     1ORD213 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m

    r613 r623  
    1 ORD214 ; COMPILED XREF FOR FILE #100.045 ; 11/08/09
     1ORD214 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m

    r613 r623  
    1 ORD215 ; COMPILED XREF FOR FILE #100.051 ; 11/08/09
     1ORD215 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m

    r613 r623  
    1 ORD216 ; COMPILED XREF FOR FILE #100.09 ; 11/08/09
     1ORD216 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m

    r613 r623  
    1 ORD22 ; COMPILED XREF FOR FILE #100.001 ; 11/08/09
     1ORD22 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06
    22 ;
    33 S DA(1)=DA S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m

    r613 r623  
    1 ORD23 ; COMPILED XREF FOR FILE #100.002 ; 11/08/09
     1ORD23 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m

    r613 r623  
    1 ORD24 ; COMPILED XREF FOR FILE #100.008 ; 11/08/09
     1ORD24 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m

    r613 r623  
    1 ORD25 ; COMPILED XREF FOR FILE #100.04 ; 11/08/09
     1ORD25 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m

    r613 r623  
    1 ORD26 ; COMPILED XREF FOR FILE #100.045 ; 11/08/09
     1ORD26 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m

    r613 r623  
    1 ORD27 ; COMPILED XREF FOR FILE #100.051 ; 11/08/09
     1ORD27 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m

    r613 r623  
    1 ORD28 ; COMPILED XREF FOR FILE #100.09 ; 11/08/09
     1ORD28 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m

    r613 r623  
    1 ORD29 ; COMPILED XREF FOR FILE #100 ; 11/08/09
     1ORD29 ; COMPILED XREF FOR FILE #100 ; 12/25/06
    22 ;
    33 S DIKZK=1

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV03.m

    r613 r623  
    1 ORDV03  ; slc/dcm - OE/RR Report Extracts ;10/8/03  11:17
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,215,243**;Dec 17, 1997;Build 242
    3 RI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)           ;Radiology impression
    4         ;External Calls: MAIN^GMTSRAE(1)
    5         ;
    6         ; ^TMP("GMTSRAD",$J) used via DBIA 4333
    7         ; ^TMP("RAE",$J) used via DBIA 3968
    8         N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO
    9         Q:'$L(OREXT)
    10         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    11         Q:'$L($T(@GO))
    12         S IOST=$G(IOST),GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS2=ORALPHA,GMTS1=OROMEGA
    13         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    14         K ^TMP("ORDATA",$J),^TMP("RAE",$J)  ;DBIA 3968
    15         D @GO
    16         S ORDT=GMTS1,ORCNT=0
    17         F  S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)!(ORDT>GMTS2)  D
    18         . S ORJ=0 F  S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ  I $G(^(ORJ,0)) S ORX0=^(0) D
    19         .. S ORCNT=ORCNT+1
    20         .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE)
    21         .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Station ID
    22         .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date
    23         .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure
    24         .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,4) ;report status
    25         .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code
    26         .. D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6)),6) ;impression
    27         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^[+]" ;flag for detail
    28         K ^TMP("RAE",$J)
    29         S ROOT=$NA(^TMP("ORDATA",$J))
    30         Q
    31 RR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)             ;Radiology report
    32         ;External Calls: MAIN^GMTSRAE(2)
    33         I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
    34         . N BEG,END,MAX
    35         . Q:'$G(ORALPHA)  Q:'$G(OROMEGA)
    36         . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999)
    37         . S BEG=9999999-OROMEGA,END=9999999-ORALPHA
    38         . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX)
    39         N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE
    40         Q:'$L(OREXT)
    41         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    42         Q:'$L($T(@GO))
    43         K ^TMP("ORDATA",$J)
    44         S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA
    45         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    46         I '$L($T(GCPR^OMGCOAS1)) D
    47         . K ^TMP("RAE",$J)
    48         . D @GO
    49         S ORDT=GMTS1,ORCNT=0
    50         F  S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)  D
    51         . S ORJ=0 F  S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ  D
    52         .. S ORCNT=ORCNT+1,ORMORE=0
    53         .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0))
    54         .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE)
    55         .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID
    56         .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date
    57         .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure
    58         .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status
    59         .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code
    60         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"S",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"S")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;reason for study
    61         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;clinical history
    62         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;impression
    63         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",9,1)),9) ;report
    64         .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",10)="10^[+]" ;flag for detail
    65         K ^TMP("RAE",$J)
    66         S ROOT=$NA(^TMP("ORDATA",$J))
    67         Q
    68 RRDOD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)          ;Radiology report
    69         ;External Calls: MAIN^GMTSRAE(2)
    70         ;
    71         I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
    72         . N BEG,END,MAX
    73         . Q:'$G(ORALPHA)  Q:'$G(OROMEGA)
    74         . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999)
    75         . S BEG=9999999-OROMEGA,END=9999999-ORALPHA
    76         . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX)
    77         ;
    78         N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE
    79         Q:'$L(OREXT)
    80         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    81         Q:'$L($T(@GO))
    82         K ^TMP("ORDATA",$J)
    83         S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA
    84         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    85         I '$L($T(GCPR^OMGCOAS1)) D
    86         . K ^TMP("RAE",$J)
    87         . D @GO
    88         S ORDT=GMTS1,ORCNT=0
    89         F  S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)  D
    90         . S ORJ=0 F  S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ  D
    91         .. S ORCNT=ORCNT+1,ORMORE=0
    92         .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0))
    93         .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE)
    94         .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID
    95         .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date
    96         .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure
    97         .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status
    98         .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code
    99         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history
    100         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;impression
    101         .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;report
    102         .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^[+]" ;flag for detail
    103         K ^TMP("RAE",$J)
    104         S ROOT=$NA(^TMP("ORDATA",$J))
    105         Q
    106 RS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)      ;Radiology status
    107         ;External calls: GET^GMTSRAD
    108         N ORSITE,SITE,CNT,ORDT,ORDA,ORDA2,REC,GMTSEND,GMTSBEG,GO,STAT
    109         Q:'$L(OREXT)
    110         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    111         Q:'$L($T(@GO))
    112         S GMTSBEG=ORDBEG,GMTSEND=ORDEND
    113         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    114         K ^TMP("GMTSRAD",$J)  ;DBIA 4333
    115         D @GO
    116         S CNT=0,ORDT=OROMEGA
    117         F  S ORDT=$O(^TMP("GMTSRAD",$J,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(CNT'<ORMAX)  D
    118         .S ORDA=0
    119         .F  S ORDA=$O(^TMP("GMTSRAD",$J,ORDT,ORDA)) Q:'ORDA!(CNT'<ORMAX)  D
    120         ..S ORDA2=0
    121         ..F  S ORDA2=$O(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2)) Q:'ORDA2!(CNT'<ORMAX)  S REC=^(ORDA2),STAT=$P(REC,"^",2) D
    122         ...S CNT=CNT+1
    123         ...S SITE=$S($L($G(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2,"facility"))):^("facility"),1:ORSITE)
    124         ...S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE
    125         ...S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(REC,"^"))
    126         ...S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$S(STAT="d":"Discontinued",STAT="c":"Complete",STAT="h":"Hold",STAT="p":"Pending",STAT="a":"Active",STAT="s":"Scheduled",STAT="u":"Unreleased",1:STAT)
    127         ...S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(REC,"^",3)
    128         ...S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(REC,"^",4))
    129         ...S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(REC,"^",5)
    130         S ROOT=$NA(^TMP("ORDATA",$J))
    131         Q
    132 RAD1    ;Get radiology impression
    133         D MAIN^GMTSRAE(1)
    134         Q
    135 RAD2    ;Get radiology report
    136         D MAIN^GMTSRAE(2)
    137         Q
     1ORDV03 ; slc/dcm - OE/RR Report Extracts ;10/8/03  11:17
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,215**;Dec 17, 1997
     3RI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)      ;Radiology impression
     4 ;External Calls: MAIN^GMTSRAE(1)
     5 ;
     6 ; ^TMP("GMTSRAD",$J) used via DBIA 4333
     7 ; ^TMP("RAE",$J) used via DBIA 3968
     8 ;
     9 I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
     10 . N BEG,END,MAX
     11 . Q:'$G(ORALPHA)  Q:'$G(OROMEGA)
     12 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999)
     13 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA
     14 . D GCPR^OMGCOAS1(DFN,"RI",BEG,END,MAX)
     15 ;
     16 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO
     17 Q:'$L(OREXT)
     18 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     19 Q:'$L($T(@GO))
     20 S IOST=$G(IOST),GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS2=ORALPHA,GMTS1=OROMEGA
     21 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     22 K ^TMP("ORDATA",$J)
     23 I '$L($T(GCPR^OMGCOAS1)) D
     24 . K ^TMP("RAE",$J)  ;DBIA 3968
     25 . D @GO
     26 S ORDT=GMTS1,ORCNT=0
     27 F  S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)!(ORDT>GMTS2)  D
     28 . S ORJ=0 F  S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ  I $G(^(ORJ,0)) S ORX0=^(0) D
     29 .. S ORCNT=ORCNT+1
     30 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE)
     31 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Station ID
     32 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date
     33 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure
     34 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,4) ;report status
     35 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code
     36 .. D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6)),6) ;impression
     37 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^[+]" ;flag for detail
     38 K ^TMP("RAE",$J)
     39 S ROOT=$NA(^TMP("ORDATA",$J))
     40 Q
     41RR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)        ;Radiology report
     42 ;External Calls: MAIN^GMTSRAE(2)
     43 ;
     44 I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
     45 . N BEG,END,MAX
     46 . Q:'$G(ORALPHA)  Q:'$G(OROMEGA)
     47 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999)
     48 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA
     49 . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX)
     50 ;
     51 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE
     52 Q:'$L(OREXT)
     53 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     54 Q:'$L($T(@GO))
     55 K ^TMP("ORDATA",$J)
     56 S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA
     57 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     58 I '$L($T(GCPR^OMGCOAS1)) D
     59 . K ^TMP("RAE",$J)
     60 . D @GO
     61 S ORDT=GMTS1,ORCNT=0
     62 F  S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)  D
     63 . S ORJ=0 F  S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ  D
     64 .. S ORCNT=ORCNT+1,ORMORE=0
     65 .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0))
     66 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE)
     67 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID
     68 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date
     69 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure
     70 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status
     71 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code
     72 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history
     73 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;impression
     74 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;report
     75 .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^[+]" ;flag for detail
     76 K ^TMP("RAE",$J)
     77 S ROOT=$NA(^TMP("ORDATA",$J))
     78 Q
     79RS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology status
     80 ;External calls: GET^GMTSRAD
     81 ;
     82 I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
     83 . N BEG,END,MAX
     84 . Q:'$G(ORALPHA)  Q:'$G(OROMEGA)
     85 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999)
     86 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA
     87 . D GCPR^OMGCOAS1(DFN,"RS",BEG,END,MAX)
     88 ;
     89 N ORSITE,SITE,CNT,ORDT,ORDA,ORDA2,REC,GMTSEND,GMTSBEG,GO,STAT
     90 Q:'$L(OREXT)
     91 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     92 Q:'$L($T(@GO))
     93 S GMTSBEG=ORDBEG,GMTSEND=ORDEND
     94 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     95 I '$L($T(GCPR^OMGCOAS1)) D
     96 . K ^TMP("GMTSRAD",$J)  ;DBIA 4333
     97 . D @GO
     98 S CNT=0,ORDT=OROMEGA
     99 F  S ORDT=$O(^TMP("GMTSRAD",$J,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(CNT'<ORMAX)  D
     100 .S ORDA=0
     101 .F  S ORDA=$O(^TMP("GMTSRAD",$J,ORDT,ORDA)) Q:'ORDA!(CNT'<ORMAX)  D
     102 ..S ORDA2=0
     103 ..F  S ORDA2=$O(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2)) Q:'ORDA2!(CNT'<ORMAX)  S REC=^(ORDA2),STAT=$P(REC,"^",2) D
     104 ...S CNT=CNT+1
     105 ...S SITE=$S($L($G(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2,"facility"))):^("facility"),1:ORSITE)
     106 ...S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE
     107 ...S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(REC,"^"))
     108 ...S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$S(STAT="d":"Discontinued",STAT="c":"Complete",STAT="h":"Hold",STAT="p":"Pending",STAT="a":"Active",STAT="s":"Scheduled",STAT="u":"Unreleased",1:STAT)
     109 ...S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(REC,"^",3)
     110 ...S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(REC,"^",4))
     111 ...S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(REC,"^",5)
     112 S ROOT=$NA(^TMP("ORDATA",$J))
     113 Q
     114RAD1 ;Get radiology impression
     115 D MAIN^GMTSRAE(1)
     116 Q
     117RAD2 ;Get radiology report
     118 D MAIN^GMTSRAE(2)
     119 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04.m

    r613 r623  
    1 ORDV04  ; SLC/DAN/dcm - OE/RR ;7/21/04  15:32
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,148,160,208,195,241,215,274,256,243**;Dec 17,1997;Build 242
    3         ;OE/RR COMPONENT
    4         ;
    5         ; ^TMP("GMPLHS",$J) DBIA 1183
    6         ; ^UTILITY & ^TMP("GMRVD") DBIA 10061
    7         ;
    8 ORC(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)     ; Current Orders
    9         ;Calls EN^ORQ1, ^OR(100
    10         N ORCNT,ORJ,ORSITE,SITE,ORX0,ORLIST,GO
    11         Q:'$L(OREXT)
    12         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    13         Q:'$L($T(@GO))
    14         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    15         K ^TMP("ORR",$J),^TMP("ORDATA",$J)
    16         D @GO
    17         I '$D(^TMP("ORR",$J)) Q
    18         S ORCNT=0,ORJ=0
    19         F  S ORJ=$O(^TMP("ORR",$J,ORLIST,ORJ)) Q:'+ORJ!(ORCNT'<ORMAX)  S ORX0=^(ORJ) D
    20         . S ORCNT=ORCNT+1,SITE=$S($L($G(^TMP("ORR",$J,ORLIST,ORJ,"facility"))):^("facility"),1:ORSITE)
    21         . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",1)="1^"_SITE ;Station ID
    22         . D SPMRG^ORDVU("^TMP(""ORR"","_$J_","""_ORLIST_""","_ORJ_",""TX"")","^TMP(""ORDATA"","_$J_","""_ORLIST_""","_ORJ_",""WP"",2)",2) ;order text
    23         . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",3)="3^"_$P(ORX0,"^",6) ; status
    24         . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,"^",4)) ;start date
    25         . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,"^",5)) ;stop date
    26         . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",7)="7^"_$P(^TMP("ORR",$J,ORLIST,ORJ),U) ;Order Number
    27         . I $O(^TMP("ORR",$J,ORLIST,ORJ,"TX",1)) S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",6)="6^[+]" ;flag for details
    28         K ^TMP("ORR",$J)
    29         S ROOT=$NA(^TMP("ORDATA",$J))
    30         Q
    31 ORCVA   ;Current Orders
    32         N ORVP
    33         S ORVP=DFN_";DPT("
    34         I '$D(^OR(100,"AC",ORVP)) Q
    35         D EN^ORQ1(ORVP,,2,,ORDBEG,ORDEND,1) ;get current orders. ORLIST is set in ORQ1
    36         Q
    37 PLAILALL(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)        ;Problem list API returns ALL problems
    38         N GO
    39         Q:'$L(OREXT)
    40         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    41         Q:'$L($T(@GO))
    42         D PLAIL
    43         Q
    44 PLALL   ;All Problems
    45         D GETLIST^GMPLHS(DFN,"ALL")
    46         Q
    47 PLAILI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)  ;Problem list API returns INACTIVE problems
    48         N GO
    49         Q:'$L(OREXT)
    50         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    51         Q:'$L($T(@GO))
    52         D PLAIL
    53         Q
    54 PLI     ;Inactive Problems
    55         D GETLIST^GMPLHS(DFN,"I")
    56         Q
    57 PLAILA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)  ;Problem list API returns ACTIVE problems
    58         N GO
    59         Q:'$L(OREXT)
    60         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    61         Q:'$L($T(@GO))
    62         D PLAIL
    63         Q
    64 PLA     ;Active Problems
    65         D GETLIST^GMPLHS(DFN,"A")
    66         Q
    67 PLAIL   ;problems(active, inactive or all)
    68         ;External calls to ^GMPLHS
    69         ; input:
    70         ;   STATUS = "A"   active problems
    71         ;   STATUS = "I"   inactive problems
    72         ;   STATUS = "ALL" all problems
    73         ;
    74         I $L($T(GCPR^OMGCOAS1)) D  Q  ; Call if FHIE station 200
    75         . S ORDBEG=0,ORDEND=9999999,ORMAX=99999
    76         . D GCPR^OMGCOAS1(DFN,"PLL",ORDBEG,ORDEND,ORMAX)
    77         . S ROOT=$NA(^TMP("ORDATA",$J))
    78         N ORPROBNO,ORXREC0,ORLOC,I,K,X,ORSITE,SITE,ORMORE
    79         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    80         K ^TMP("ORDATA",$J),^TMP("GMPLHS",$J)  ;DBIA #1183
    81         D @GO
    82         I '$D(^TMP("GMPLHS",$J)) Q
    83         S ORPROBNO=0
    84         F I=1:1 S ORPROBNO=$O(^TMP("GMPLHS",$J,ORPROBNO)) Q:'ORPROBNO  D
    85         . S ORXREC0=$G(^TMP("GMPLHS",$J,ORPROBNO,0)),ORMORE=0
    86         . S SITE=$S($L($G(^TMP("GMPLHS",$J,ORPROBNO,"facility"))):^("facility"),1:ORSITE)
    87         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",1)="1^"_SITE ;Station ID
    88         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",2)="2^"_$P(ORXREC0,U,5) ;status
    89         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",3)="3^"_$G(^TMP("GMPLHS",$J,ORPROBNO,"N")) ;provider narrative
    90         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",4)="4^"_$$DATE^ORDVU($P(ORXREC0,U,6)) ;onset date
    91         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",5)="5^"_$$DATE^ORDVU($P(ORXREC0,U,2)) ;last modified date
    92         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",6)="6^"_$P(ORXREC0,U,7) ;provider
    93         . S ORLOC=0,K=0
    94         . F  S ORLOC=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC)) Q:'ORLOC  D
    95         .. S X=0
    96         .. F  S X=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X)) Q:'X  D
    97         ... S K=K+1,ORMORE=1
    98         ... S ^TMP("ORDATA",$J,ORPROBNO,"WP",7,K)="7^"_$P($G(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X,0)),U) ;note narrative
    99         . S ^TMP("ORDATA",$J,ORPROBNO,"WP",8)="8^"_$P(ORXREC0,U,14) ;exposures
    100         . I ORMORE S ^TMP("ORDATA",$J,ORPROBNO,"WP",9)="9^[+]" ;flag for details
    101         K ^TMP("GMPLHS",$J)
    102         S ROOT=$NA(^TMP("ORDATA",$J))
    103         Q
    104 SR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)      ;Surgery Report
    105         ;Call ^ORDV04A
    106         N ORCNT
    107         S ORCNT=0
    108         K ^TMP("ORDATA",$J)
    109         D ENSR^ORDV04A
    110         S ROOT=$NA(^TMP("ORDATA",$J))
    111         Q
    112 VS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)      ; get vital Signs
    113         D VS^ORDV04A
    114         Q
    115 TIUPRG(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)  ;  TIU version of progress reports
    116         ;Calls to TIUSRVLO,TIUSRVR1,VASITE
    117         I $L($T(GCPR^OMGCOAS1)) D  Q  ; Call if FHIE station 200
    118         . D GCPR^OMGCOAS1(DFN,"PN",ORDBEG,ORDEND,ORMAX)
    119         . S ROOT=$NA(^TMP("ORDATA",$J))
    120         N ORDT,DATE,ORCI,ORGLOB,ORGLOBA,ORTEMP,ORSITE,SITE,I,ORNODE,GO,ORIMAG
    121         Q:'$L(OREXT)
    122         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    123         Q:'$L($T(@GO))
    124         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    125         D @GO
    126         I '$D(@ORGLOB) Q
    127         S ORNODE=0,ORCI=0
    128         K ^TMP("ORDATA",$J)
    129         F  S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORCI'<ORMAX)  D
    130         . S ORTEMP=@ORGLOB@(ORNODE)
    131         . S ORIMAG=$P($$RESOLVE^TIUSRVLO($P(ORTEMP,U)),U,10)
    132         . S DATE=$P(ORTEMP,U,3)       ;date
    133         . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE)
    134         . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID
    135         . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$P(ORTEMP,U) ;TIU ien
    136         . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATE^ORDVU(DATE) ;date
    137         . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$P(ORTEMP,U,2) ;type
    138         . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$P($P(ORTEMP,U,5),";",2) ;author
    139         . S ORCI=ORCI+1
    140         . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call back to get note text
    141         . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",6)),6) ;Notes Text
    142         . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",7)="7^[+]"
    143         . S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^"_ORIMAG
    144         . K @ORGLOBA
    145         K @ORGLOB
    146         S ROOT=$NA(^TMP("ORDATA",$J))
    147         Q
    148 TPRG    ;TIU Progress Notes
    149         D CONTEXT^TIUSRVLO(.ORGLOB,3,5,DFN,ORDBEG,ORDEND,,ORMAX)
    150         Q
    151 TIUDCS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)  ;  Discharge Summaries
    152         ;Calls VASITE, DIQ1, TIUSRVLO
    153         I $L($T(GCPR^OMGCOAS1)) D  Q  ; Call if FHIE station 200
    154         . D GCPR^OMGCOAS1(DFN,"DS",ORDBEG,ORDEND,ORMAX)
    155         . S ROOT=$NA(^TMP("ORDATA",$J))
    156         N ORGLOB,ORGLOBA,ORI,ORNODE,ORICDIEN,ORARRAY,ORTEMP,ORSITE,SITE,DIC,DR,DIQ,DA,GO
    157         Q:'$L(OREXT)
    158         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    159         Q:'$L($T(@GO))
    160         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    161         D @GO
    162         I '$D(@ORGLOB) Q
    163         K ^TMP("ORDATA",$J)
    164         S ORNODE=0,ORI=0
    165         F  S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORI'<ORMAX)  D
    166         . S ORTEMP=@ORGLOB@(ORNODE)
    167         . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE)
    168         . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID
    169         . K ORARRAY S DIC=8925,DA=$P(ORTEMP,U),DR=".05;.07;.08;1202;1502",DIQ="ORARRAY"
    170         . D EN^DIQ1
    171         . S DIQ="ORARRAY(8925,"_DA_")"
    172         . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$$DATEMMM^ORDVU($G(@DIQ@(.07))) ;episode begin date/time
    173         . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATEMMM^ORDVU($G(@DIQ@(.08))) ;episode end date/time
    174         . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$G(@DIQ@(1202)) ;author/dicator
    175         . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$G(@DIQ@(1502)) ;signed by
    176         . S ^TMP("ORDATA",$J,ORNODE,"WP",6)="6^"_$G(@DIQ@(.05)) ;status
    177         . S ORI=ORI+1
    178         . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call to get summary text
    179         . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",7)),7) ;summary Text
    180         . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^[+]" ;detail flag
    181         . K @ORGLOBA
    182         K @ORGLOB
    183         S ROOT=$NA(^TMP("ORDATA",$J))
    184         Q
    185 TDCS    ;TIU Discharge Summary
    186         D CONTEXT^TIUSRVLO(.ORGLOB,244,5,DFN,ORDBEG,ORDEND,,ORMAX)
    187         Q
     1ORDV04 ; SLC/DAN - OE/RR ;7/21/04  15:32
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,148,160,208,195,241,215,274**;Dec 17,1997;Build 20
     3 ;OE/RR COMPONENT
     4 ;
     5 ; ^TMP("GMPLHS",$J) used per DBIA 1183
     6 ; ^UTILITY and ^TMP("GMRVD") used per DBIA 10061
     7 ;
     8ORC(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Current Orders
     9 ;External calls to EN^ORQ1, ^OR(100
     10 N ORCNT,ORJ,ORSITE,SITE,ORX0,ORLIST,GO
     11 Q:'$L(OREXT)
     12 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     13 Q:'$L($T(@GO))
     14 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     15 K ^TMP("ORR",$J),^TMP("ORDATA",$J)
     16 D @GO
     17 I '$D(^TMP("ORR",$J)) Q
     18 S ORCNT=0,ORJ=0
     19 F  S ORJ=$O(^TMP("ORR",$J,ORLIST,ORJ)) Q:'+ORJ!(ORCNT'<ORMAX)  S ORX0=^(ORJ) D
     20 . S ORCNT=ORCNT+1,SITE=$S($L($G(^TMP("ORR",$J,ORLIST,ORJ,"facility"))):^("facility"),1:ORSITE)
     21 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",1)="1^"_SITE ;Station ID
     22 . D SPMRG^ORDVU("^TMP(""ORR"","_$J_","""_ORLIST_""","_ORJ_",""TX"")","^TMP(""ORDATA"","_$J_","""_ORLIST_""","_ORJ_",""WP"",2)",2) ;order text
     23 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",3)="3^"_$P(ORX0,"^",6) ; status
     24 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,"^",4)) ;start date
     25 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,"^",5)) ;stop date
     26 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",7)="7^"_$P(^TMP("ORR",$J,ORLIST,ORJ),U) ;Order Number
     27 . I $O(^TMP("ORR",$J,ORLIST,ORJ,"TX",1)) S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",6)="6^[+]" ;flag for details
     28 K ^TMP("ORR",$J)
     29 S ROOT=$NA(^TMP("ORDATA",$J))
     30 Q
     31ORCVA ;VA call to get Current Orders
     32 N ORVP
     33 S ORVP=DFN_";DPT("
     34 I '$D(^OR(100,"AC",ORVP)) Q
     35 D EN^ORQ1(ORVP,,2,,ORDBEG,ORDEND,1) ;get current orders. ORLIST is set in ORQ1
     36 Q
     37PLAILALL(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns ALL problems
     38 N GO
     39 Q:'$L(OREXT)
     40 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     41 Q:'$L($T(@GO))
     42 D PLAIL
     43 Q
     44PLALL ;Jump here for All Problems
     45 D GETLIST^GMPLHS(DFN,"ALL")
     46 Q
     47PLAILI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns INACTIVE problems
     48 N GO
     49 Q:'$L(OREXT)
     50 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     51 Q:'$L($T(@GO))
     52 D PLAIL
     53 Q
     54PLI ;Jump here for Inactive Problems
     55 D GETLIST^GMPLHS(DFN,"I")
     56 Q
     57PLAILA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns ACTIVE problems
     58 N GO
     59 Q:'$L(OREXT)
     60 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     61 Q:'$L($T(@GO))
     62 D PLAIL
     63 Q
     64PLA ;Jump here for Active Problems
     65 D GETLIST^GMPLHS(DFN,"A")
     66 Q
     67PLAIL ;problems(active, inactive or all)
     68 ;External calls to ^GMPLHS
     69 ; input:
     70 ;   STATUS = "A"   to produce active problems
     71 ;   STATUS = "I"   to produce inactive problems
     72 ;   STATUS = "ALL" to produce all problems
     73 ;
     74 N ORPROBNO,ORXREC0,ORLOC,I,K,X,ORSITE,SITE,ORMORE
     75 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     76 K ^TMP("ORDATA",$J),^TMP("GMPLHS",$J)  ;DBIA #1183
     77 D @GO
     78 I '$D(^TMP("GMPLHS",$J)) Q
     79 S ORPROBNO=0
     80 F I=1:1:ORMAX S ORPROBNO=$O(^TMP("GMPLHS",$J,ORPROBNO)) Q:'ORPROBNO  D
     81 . S ORXREC0=$G(^TMP("GMPLHS",$J,ORPROBNO,0)),ORMORE=0
     82 . S SITE=$S($L($G(^TMP("GMPLHS",$J,ORPROBNO,"facility"))):^("facility"),1:ORSITE)
     83 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",1)="1^"_SITE ;Station ID
     84 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",2)="2^"_$P(ORXREC0,U,5) ;status
     85 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",3)="3^"_$G(^TMP("GMPLHS",$J,ORPROBNO,"N")) ;provider narrative
     86 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",4)="4^"_$$DATE^ORDVU($P(ORXREC0,U,6)) ;onset date
     87 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",5)="5^"_$$DATE^ORDVU($P(ORXREC0,U,2)) ;last modified date
     88 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",6)="6^"_$P(ORXREC0,U,7) ;provider
     89 . S ORLOC=0,K=0
     90 . F  S ORLOC=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC)) Q:'ORLOC  D
     91 .. S X=0
     92 .. F  S X=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X)) Q:'X  D
     93 ... S K=K+1,ORMORE=1
     94 ... S ^TMP("ORDATA",$J,ORPROBNO,"WP",7,K)="7^"_$P($G(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X,0)),U) ;note narrative
     95 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",8)="8^"_$P(ORXREC0,U,14) ;exposures
     96 . I ORMORE S ^TMP("ORDATA",$J,ORPROBNO,"WP",9)="9^[+]" ;flag for details
     97 K ^TMP("GMPLHS",$J)
     98 S ROOT=$NA(^TMP("ORDATA",$J))
     99 Q
     100SR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Surgery Report
     101 ;External call to ^ORDV04A (external calls are noted in that routine)
     102 N ORCNT
     103 S ORCNT=0
     104 K ^TMP("ORDATA",$J)
     105 D ENSR^ORDV04A
     106 S ROOT=$NA(^TMP("ORDATA",$J))
     107 Q
     108VS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; get vital Signs
     109 ;External calls to GMRVUT0
     110 I $L($T(GCPR^OMGCOAS1)) D  Q  ; OMGCOAS1 routine only on Station 200
     111 . D GCPR^OMGCOAS1(DFN,"VIT",ORDBEG,ORDEND,ORMAX)
     112 . S ROOT=$NA(^TMP("ORDATA",$J))
     113 N ORDT,I,TYPE,IEN,GMRVSTR,ORSITE,SITE,PLACE,GO
     114 Q:'$L(OREXT)
     115 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     116 Q:'$L($T(@GO))
     117 K ^UTILITY($J,"GMRVD"),^TMP("ORDATA",$J)
     118 S GMRVSTR="T;P;R;BP;HT;WT;PN;PO2;CVP;CG",GMRVSTR(0)=ORDBEG_"^"_ORDEND_"^"_ORMAX_"^"_1
     119 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     120 D @GO
     121 S ORDT=0
     122 F I=1:1 S ORDT=$O(^UTILITY($J,"GMRVD",ORDT)) Q:'+ORDT!(I>ORMAX)  D  ;DBIA 10061
     123 . S SITE=$S($L($G(^TMP("GMRVD",$J,ORDT,"facility"))):^("facility"),1:ORSITE)  ;DBIA 10061
     124 . S ^TMP("ORDATA",$J,"WP",ORDT,1)="1^"_SITE
     125 . S ^TMP("ORDATA",$J,"WP",ORDT,2)="2^"_$$DATE^ORDVU(9999999-ORDT) ;date vitals taken
     126 . S TYPE=""
     127 . F  S TYPE=$O(^UTILITY($J,"GMRVD",ORDT,TYPE)) Q:TYPE=""  D
     128 .. S IEN=$O(^UTILITY($J,"GMRVD",ORDT,TYPE,0)) Q:'IEN
     129 .. S PLACE=$S(TYPE="T":3,TYPE="P":4,TYPE="R":5,TYPE="BP":6,TYPE="HT":7,TYPE="WT":8,TYPE="PN":9,TYPE="PO2":10,TYPE="CVP":11,TYPE="CG":12,1:13)
     130 .. S ^TMP("ORDATA",$J,"WP",ORDT,PLACE)=PLACE_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",8) ;Get value of vitals from global
     131 K ^UTILITY($J,"GMRVD")
     132 S ROOT=$NA(^TMP("ORDATA",$J))
     133 Q
     134TIUPRG(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;  TIU version of progress reports
     135 ;External calls to TIUSRVLO,TIUSRVR1,VASITE
     136 I $L($T(GCPR^OMGCOAS1)) D  Q  ; Call if FHIE station 200
     137 . D GCPR^OMGCOAS1(DFN,"PN",ORDBEG,ORDEND,ORMAX)
     138 . S ROOT=$NA(^TMP("ORDATA",$J))
     139 N ORDT,DATE,ORCI,ORGLOB,ORGLOBA,ORTEMP,ORSITE,SITE,I,ORNODE,GO,ORIMAG
     140 Q:'$L(OREXT)
     141 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     142 Q:'$L($T(@GO))
     143 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     144 D @GO
     145 I '$D(@ORGLOB) Q
     146 S ORNODE=0,ORCI=0
     147 K ^TMP("ORDATA",$J)
     148 F  S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORCI'<ORMAX)  D
     149 . S ORTEMP=@ORGLOB@(ORNODE)
     150 . S ORIMAG=$P($$RESOLVE^TIUSRVLO($P(ORTEMP,U)),U,10)
     151 . S DATE=$P(ORTEMP,U,3)       ;date
     152 . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE)
     153 . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID
     154 . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$P(ORTEMP,U) ;TIU ien
     155 . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATE^ORDVU(DATE) ;date
     156 . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$P(ORTEMP,U,2) ;type
     157 . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$P($P(ORTEMP,U,5),";",2) ;author
     158 . S ORCI=ORCI+1
     159 . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call back to get note text
     160 . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",6)),6) ;Notes Text
     161 . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",7)="7^[+]"
     162 . S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^"_ORIMAG
     163 . K @ORGLOBA
     164 K @ORGLOB
     165 S ROOT=$NA(^TMP("ORDATA",$J))
     166 Q
     167TPRG ;Jump here for Tiu Progress Notes
     168 D CONTEXT^TIUSRVLO(.ORGLOB,3,5,DFN,ORDBEG,ORDEND,,ORMAX)
     169 Q
     170TIUDCS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;  Discharge Summaries
     171 ;External calls to VASITE, DIQ1, TIUSRVLO
     172 I $L($T(GCPR^OMGCOAS1)) D  Q  ; Call if FHIE station 200
     173 . D GCPR^OMGCOAS1(DFN,"DS",ORDBEG,ORDEND,ORMAX)
     174 . S ROOT=$NA(^TMP("ORDATA",$J))
     175 N ORGLOB,ORGLOBA,ORI,ORNODE,ORICDIEN,ORARRAY,ORTEMP,ORSITE,SITE,DIC,DR,DIQ,DA,GO
     176 Q:'$L(OREXT)
     177 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     178 Q:'$L($T(@GO))
     179 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     180 D @GO
     181 I '$D(@ORGLOB) Q
     182 K ^TMP("ORDATA",$J)
     183 S ORNODE=0,ORI=0
     184 F  S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORI'<ORMAX)  D
     185 . S ORTEMP=@ORGLOB@(ORNODE)
     186 . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE)
     187 . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID
     188 . K ORARRAY S DIC=8925,DA=$P(ORTEMP,U),DR=".05;.07;.08;1202;1502",DIQ="ORARRAY"
     189 . D EN^DIQ1
     190 . S DIQ="ORARRAY(8925,"_DA_")"
     191 . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$$DATEMMM^ORDVU($G(@DIQ@(.07))) ;episode begin date/time
     192 . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATEMMM^ORDVU($G(@DIQ@(.08))) ;episode end date/time
     193 . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$G(@DIQ@(1202)) ;author/dicator
     194 . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$G(@DIQ@(1502)) ;signed by
     195 . S ^TMP("ORDATA",$J,ORNODE,"WP",6)="6^"_$G(@DIQ@(.05)) ;status
     196 . S ORI=ORI+1
     197 . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call back to get summary text
     198 . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",7)),7) ;summary Text
     199 . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^[+]" ;detail flag
     200 . K @ORGLOBA
     201 K @ORGLOB
     202 S ROOT=$NA(^TMP("ORDATA",$J))
     203 Q
     204TDCS ;Jump here for TIU Discharge Summary
     205 D CONTEXT^TIUSRVLO(.ORGLOB,244,5,DFN,ORDBEG,ORDEND,,ORMAX)
     206 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04A.m

    r613 r623  
    1 ORDV04A ; SLC/DAN/dcm - OE/RR ;7/30/01  14:33
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,243**;Dec 17,1997;Build 242
    3         ;
    4         Q
    5 ENSR    ; Entry point for component
    6         ;External calls to ^GMTSROB, ^DIQ, ^GMTSORC, ^DIWP
    7         ;External references to ^SRF, ^DD, ^ICPT
    8         N GMIDT,GMN,SURG
    9         I '$D(^SRF("B",DFN)) Q
    10         S GMN=0 F  S GMN=$O(^SRF("B",DFN,GMN)) Q:GMN'>0  D SORT
    11         I '$D(SURG) Q
    12         S GMIDT=0 F  S GMIDT=$O(SURG(GMIDT)) Q:GMIDT'>0!(ORCNT'<ORMAX)  S GMN=SURG(GMIDT) D EXTRCT
    13         Q
    14         ;
    15 SORT    ; Sort surgeries by inverted date
    16         N GMDT
    17         S GMDT=$P(^SRF(GMN,0),U,9) I GMDT>ORDBEG&(GMDT<ORDEND) D
    18         . F  Q:'$D(SURG(9999999-GMDT))  S GMDT=GMDT+.0001
    19         . S SURG(9999999-GMDT)=GMN
    20         Q
    21 EXTRCT  ; Extract surgical case record
    22         N X,GMI,GMDT,OPPRC,POSDX,PREDX,SPEC,STATUS,SURGEON,VER
    23         N DCTDTM,TRSDTM,Y,C,DIWL,DIWF,ORSITE,ORMORE,SITE
    24         S ORCNT=ORCNT+1,ORMORE=0
    25         S GMDT=$$DATE^ORDVU($P(^SRF(GMN,0),U,9))
    26         D STATUS^GMTSROB S:'$D(STATUS) STATUS="UNKNOWN"
    27         S X=$P(^SRF(GMN,0),U,4) I X>0 S Y=X,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y
    28         I $D(^SRF(GMN,.1)) S X=$P(^SRF(GMN,.1),U,4) I X>0 S Y=X,C=$P(^DD(130,.14,0),U,2) D Y^DIQ S SURGEON=Y K Y
    29         S VER=$S($G(^SRF(GMN,"VER"))'="Y":"(Unverified)",1:"")
    30         S PREDX(0)=$S($G(^SRF(GMN,33))]"":$P(^(33),U),1:"") S GMI=0 F  S GMI=$O(^SRF(GMN,14,GMI)) Q:GMI'>0  S PREDX(GMI)=$P(^SRF(GMN,14,GMI,0),U)
    31         S POSDX(0)=$S($G(^SRF(GMN,34))]"":$P(^(34),U),1:"") S GMI=0 F  S GMI=$O(^SRF(GMN,15,GMI)) Q:GMI'>0  S POSDX(GMI)=$P(^SRF(GMN,15,GMI,0),U)
    32         S OPPRC(0)=$P($G(^SRF(GMN,"OP")),U,1,2) S:$P(OPPRC(0),U,2)]"" $P(OPPRC(0),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,"OP")),U,2)),U,3) D
    33         . S GMI=0 F  S GMI=$O(^SRF(GMN,13,GMI)) Q:GMI'>0  S OPPRC(GMI)=$P($G(^SRF(GMN,13,GMI,0)),U)_U_$G(^SRF(GMN,13,GMI,2)) S:$P(OPPRC(GMI),U,2)]"" $P(OPPRC(GMI),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,13,GMI,2)),U)),U,3)
    34         S X=$P($G(^SRF(GMN,31)),U,6) S:X>0 DCTDTM=$$DATE^ORDVU(X)
    35         S X=$P($G(^SRF(GMN,31)),U,7) S:X>0 TRSDTM=$$DATE^ORDVU(X)
    36         S DIWL=0,DIWF="N",ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    37         K ^UTILITY($J,"W")
    38         I $D(^SRF(GMN,12)) F GMI=1:1:$P(^SRF(GMN,12,0),U,4) S X=^SRF(GMN,12,GMI,0) D ^DIWP
    39         S SITE=ORSITE
    40         S ^TMP("ORDATA",$J,GMIDT,"WP",1)="1^"_SITE ;Station ID
    41         S ^TMP("ORDATA",$J,GMIDT,"WP",2)="2^"_GMDT ; date
    42         ;
    43         ; Operative Procedure(s)
    44         S GMI="" F  S GMI=$O(OPPRC(GMI)) Q:GMI=""  D  S:GMI ORMORE=1
    45         . S ^TMP("ORDATA",$J,GMIDT,"WP",3,GMI)="3^"_$P(OPPRC(GMI),U)_$S($P(OPPRC(GMI),U,2)]"":" - "_$P(OPPRC(GMI),U,2),1:"")
    46         ;
    47         S ^TMP("ORDATA",$J,GMIDT,"WP",4)="4^"_$G(SPEC) ;surgical specialty
    48         ;
    49         S ^TMP("ORDATA",$J,GMIDT,"WP",5)="5^"_$G(SURGEON) ; surgeon
    50         S ^TMP("ORDATA",$J,GMIDT,"WP",6)="6^"_$G(STATUS) ; op status
    51         ;
    52         ; Pre-operative diagnosis
    53         S GMI="" F  S GMI=$O(PREDX(GMI)) Q:GMI=""  D  S:GMI ORMORE=1
    54         . S ^TMP("ORDATA",$J,GMIDT,"WP",7,GMI)="7^"_PREDX(GMI)
    55         ;
    56         ; Post-operative diagnosis
    57         S GMI="" F  S GMI=$O(POSDX(GMI)) Q:GMI=""  D  S:GMI ORMORE=1
    58         . S ^TMP("ORDATA",$J,GMIDT,"WP",8,GMI)="8^"_POSDX(GMI)
    59         ;
    60         ; Lab work? Y/N
    61         S ^TMP("ORDATA",$J,GMIDT,"WP",9)="9^"_$S($O(^SRF(GMN,9,0)):"Yes",1:"No")
    62         S ^TMP("ORDATA",$J,GMIDT,"WP",10)="10^"_$G(DCTDTM) ; dictation time
    63         S ^TMP("ORDATA",$J,GMIDT,"WP",11)="11^"_$G(TRSDTM) ; transcription time
    64         ;
    65         ; surgeon's dictation
    66         I $D(^UTILITY($J,"W")) D  S ORMORE=1
    67         . K ^TMP("ORHSSRT",$J)
    68         . F GMI=1:1:^UTILITY($J,"W",DIWL) D
    69         .. S ^TMP("ORHSSRT",$J,GMIDT,"WP",GMI)=^UTILITY($J,"W",DIWL,GMI,0)
    70         . D SPMRG^ORDVU($NA(^TMP("ORHSSRT",$J,GMIDT,"WP")),$NA(^TMP("ORDATA",$J,GMIDT,"WP",12)),12)
    71         . K ^UTILITY($J,"W")
    72         . K ^TMP("ORHSSRT",$J)
    73         I ORMORE S ^TMP("ORDATA",$J,GMIDT,"WP",13)="13^[+]" ;flag for detail
    74         Q
    75 VS      ;Continuation of Vitals Extract (from ORDV04)
    76         ;Calls GMRVUT0
    77         I $L($T(GCPR^OMGCOAS1)) D  Q  ; OMGCOAS1 routine only on Station 200
    78         . D GCPR^OMGCOAS1(DFN,"VIT",ORDBEG,ORDEND,ORMAX)
    79         . S ROOT=$NA(^TMP("ORDATA",$J))
    80         N ORDT,I,TYPE,IEN,GMRVSTR,ORSITE,SITE,PLACE,GO,X,QUALIF,NODE,UNITS,UCNT,QCNT,ORI
    81         Q:'$L(OREXT)
    82         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    83         Q:'$L($T(@GO))
    84         K ^UTILITY($J,"GMRVD"),^TMP("ORDATA",$J)
    85         S GMRVSTR="T;P;R;BP;HT;WT;PN;PO2;CVP;CG",GMRVSTR(0)=ORDBEG_"^"_ORDEND_"^"_ORMAX_"^"_1
    86         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    87         D @GO
    88         S ORDT=0
    89         F I=1:1 S ORDT=$O(^UTILITY($J,"GMRVD",ORDT)) Q:'+ORDT!(I>ORMAX)  D  ;DBIA 4791
    90         . S SITE=$S($L($G(^TMP("GMRVD",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
    91         . S ^TMP("ORDATA",$J,"WP",ORDT,1)="1^"_SITE
    92         . S ^TMP("ORDATA",$J,"WP",ORDT,2)="2^"_$$DATE^ORDVU(9999999-ORDT) ;date vitals taken
    93         . K UNITS,QUALIF
    94         . S TYPE="",(UCNT,QCNT)=1,UNITS(UCNT)="",QUALIF(QCNT)="",QUALIF=""
    95         . F  S TYPE=$O(^UTILITY($J,"GMRVD",ORDT,TYPE)) Q:TYPE=""  D
    96         .. S IEN=$O(^UTILITY($J,"GMRVD",ORDT,TYPE,0)) Q:'IEN  S NODE=$G(^(IEN))
    97         .. S PLACE=$S(TYPE="T":3,TYPE="P":4,TYPE="R":5,TYPE="BP":6,TYPE="HT":7,TYPE="WT":8,TYPE="PN":9,TYPE="PO2":10,TYPE="CVP":11,TYPE="CG":12,1:0)
    98         .. I PLACE S ^TMP("ORDATA",$J,"WP",ORDT,PLACE)=PLACE_"^"_$P(NODE,"^",8) ;Get value of vitals from global
    99         .. S X=$$UNITMAP(TYPE) S:$L(UNITS(UCNT))>60 UCNT=UCNT+1,UNITS(UCNT)="" S UNITS(UCNT)=$S($L(UNITS(UCNT)):UNITS(UCNT)_","_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ;Units
    100         .. I TYPE="PO2" D
    101         ... I $L($P(NODE,"^",15)) S ^TMP("ORDATA",$J,"WP",ORDT,13)=13_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",15) ; Flow Rate
    102         ... I $L($P(NODE,"^",16)) S ^TMP("ORDATA",$J,"WP",ORDT,14)=14_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",16) ; O2 Concentration
    103         .. I $L($P(NODE,"^",17)) S X=$P(NODE,"^",17)  D
    104         ... I QUALIF'[($$MAP(TYPE)_":"_X) D
    105         .... S QUALIF=$S($L(QUALIF):QUALIF_" , "_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ; Qualifier
    106         .... S:$L(QUALIF(QCNT))>60 QCNT=QCNT+1,QUALIF(QCNT)=""
    107         .... S QUALIF(QCNT)=$S($L(QUALIF(QCNT)):QUALIF(QCNT)_" , "_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ; Qualifier
    108         .. I TYPE="WT",$L($P(NODE,"^",14)) D
    109         ... S ^TMP("ORDATA",$J,"WP",ORDT,16)=16_"^"_$P(NODE,"^",14) ; BMI
    110         . I $O(QUALIF(0)) D
    111         .. S ORI=0 F  S ORI=$O(QUALIF(ORI)) Q:'ORI  D
    112         ... S ^TMP("ORDATA",$J,"WP",ORDT,15,ORI)="15^"_QUALIF(ORI)
    113         . I $O(UNITS(0)) D
    114         .. S ORI=0 F  S ORI=$O(UNITS(ORI)) Q:'ORI  D
    115         ... S ^TMP("ORDATA",$J,"WP",ORDT,17,ORI)="17^"_UNITS(ORI)
    116         K ^UTILITY($J,"GMRVD")
    117         S ROOT=$NA(^TMP("ORDATA",$J))
    118         Q
    119 MAP(TEXT)       ;Map test code to abbreviation
    120         Q:'$L($G(TEXT)) ""
    121         I TEXT="T" Q "TEMP"
    122         I TEXT="P" Q "PULSE"
    123         I TEXT="R" Q "RESP"
    124         I TEXT="BP" Q "BP"
    125         I TEXT="HT" Q "HT"
    126         I TEXT="WT" Q "WT"
    127         I TEXT="PN" Q "PAIN"
    128         I TEXT="PO2" Q "POx"
    129         I TEXT="CVP" Q "CVP"
    130         I TEXT="CG" Q "C/G"
    131         Q TEXT
    132 UNITMAP(TEXT)   ;Map units to abbreviation
    133         Q:'$L($G(TEXT)) ""
    134         I TEXT="T" Q "F"
    135         I TEXT="P" Q "/min"
    136         I TEXT="R" Q " /min"
    137         I TEXT="BP" Q "mmHg"
    138         I TEXT="HT" Q "in"
    139         I TEXT="WT" Q "lb"
    140         I TEXT="PN" Q ""
    141         I TEXT="PO2" Q "%SpO2"
    142         I TEXT="CVP" Q "cmH2O"
    143         I TEXT="CG" Q " in"
    144         Q ""
     1ORDV04A ;SLC/DAN - OE/RR ;7/30/01  14:33
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109**;Dec 17,1997
     3 ;
     4 Q
     5ENSR ; Entry point for component
     6 ;External calls to ^GMTSROB, ^DIQ, ^GMTSORC, ^DIWP
     7 ;External references to ^SRF, ^DD, ^ICPT
     8 N GMIDT,GMN,SURG
     9 I '$D(^SRF("B",DFN)) Q
     10 S GMN=0 F  S GMN=$O(^SRF("B",DFN,GMN)) Q:GMN'>0  D SORT
     11 I '$D(SURG) Q
     12 S GMIDT=0 F  S GMIDT=$O(SURG(GMIDT)) Q:GMIDT'>0!(ORCNT'<ORMAX)  S GMN=SURG(GMIDT) D EXTRCT
     13 Q
     14 ;
     15SORT ; Sort surgeries by inverted date
     16 N GMDT
     17 S GMDT=$P(^SRF(GMN,0),U,9) I GMDT>ORDBEG&(GMDT<ORDEND) D
     18 . F  Q:'$D(SURG(9999999-GMDT))  S GMDT=GMDT+.0001
     19 . S SURG(9999999-GMDT)=GMN
     20 Q
     21EXTRCT ; Extract surgical case record
     22 N X,GMI,GMDT,OPPRC,POSDX,PREDX,SPEC,STATUS,SURGEON,VER
     23 N DCTDTM,TRSDTM,Y,C,DIWL,DIWF,ORSITE,ORMORE,SITE
     24 S ORCNT=ORCNT+1,ORMORE=0
     25 S GMDT=$$DATE^ORDVU($P(^SRF(GMN,0),U,9))
     26 D STATUS^GMTSROB S:'$D(STATUS) STATUS="UNKNOWN"
     27 S X=$P(^SRF(GMN,0),U,4) I X>0 S Y=X,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y
     28 I $D(^SRF(GMN,.1)) S X=$P(^SRF(GMN,.1),U,4) I X>0 S Y=X,C=$P(^DD(130,.14,0),U,2) D Y^DIQ S SURGEON=Y K Y
     29 S VER=$S($G(^SRF(GMN,"VER"))'="Y":"(Unverified)",1:"")
     30 S PREDX(0)=$S($G(^SRF(GMN,33))]"":$P(^(33),U),1:"") S GMI=0 F  S GMI=$O(^SRF(GMN,14,GMI)) Q:GMI'>0  S PREDX(GMI)=$P(^SRF(GMN,14,GMI,0),U)
     31 S POSDX(0)=$S($G(^SRF(GMN,34))]"":$P(^(34),U),1:"") S GMI=0 F  S GMI=$O(^SRF(GMN,15,GMI)) Q:GMI'>0  S POSDX(GMI)=$P(^SRF(GMN,15,GMI,0),U)
     32 S OPPRC(0)=$P($G(^SRF(GMN,"OP")),U,1,2) S:$P(OPPRC(0),U,2)]"" $P(OPPRC(0),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,"OP")),U,2)),U,3) D
     33 . S GMI=0 F  S GMI=$O(^SRF(GMN,13,GMI)) Q:GMI'>0  S OPPRC(GMI)=$P($G(^SRF(GMN,13,GMI,0)),U)_U_$G(^SRF(GMN,13,GMI,2)) S:$P(OPPRC(GMI),U,2)]"" $P(OPPRC(GMI),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,13,GMI,2)),U)),U,3)
     34 S X=$P($G(^SRF(GMN,31)),U,6) S:X>0 DCTDTM=$$DATE^ORDVU(X)
     35 S X=$P($G(^SRF(GMN,31)),U,7) S:X>0 TRSDTM=$$DATE^ORDVU(X)
     36 S DIWL=0,DIWF="N",ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     37 K ^UTILITY($J,"W")
     38 I $D(^SRF(GMN,12)) F GMI=1:1:$P(^SRF(GMN,12,0),U,4) S X=^SRF(GMN,12,GMI,0) D ^DIWP
     39 S SITE=ORSITE
     40 S ^TMP("ORDATA",$J,GMIDT,"WP",1)="1^"_SITE ;Station ID
     41 S ^TMP("ORDATA",$J,GMIDT,"WP",2)="2^"_GMDT ; date
     42 ;
     43 ; Operative Procedure(s)
     44 S GMI="" F  S GMI=$O(OPPRC(GMI)) Q:GMI=""  D  S:GMI ORMORE=1
     45 . S ^TMP("ORDATA",$J,GMIDT,"WP",3,GMI)="3^"_$P(OPPRC(GMI),U)_$S($P(OPPRC(GMI),U,2)]"":" - "_$P(OPPRC(GMI),U,2),1:"")
     46 ;
     47 S ^TMP("ORDATA",$J,GMIDT,"WP",4)="4^"_$G(SPEC) ;surgical specialty
     48 ;
     49 S ^TMP("ORDATA",$J,GMIDT,"WP",5)="5^"_$G(SURGEON) ; surgeon
     50 S ^TMP("ORDATA",$J,GMIDT,"WP",6)="6^"_$G(STATUS) ; op status
     51 ;
     52 ; Pre-operative diagnosis
     53 S GMI="" F  S GMI=$O(PREDX(GMI)) Q:GMI=""  D  S:GMI ORMORE=1
     54 . S ^TMP("ORDATA",$J,GMIDT,"WP",7,GMI)="7^"_PREDX(GMI)
     55 ;
     56 ; Post-operative diagnosis
     57 S GMI="" F  S GMI=$O(POSDX(GMI)) Q:GMI=""  D  S:GMI ORMORE=1
     58 . S ^TMP("ORDATA",$J,GMIDT,"WP",8,GMI)="8^"_POSDX(GMI)
     59 ;
     60 ; Lab work? Y/N
     61 S ^TMP("ORDATA",$J,GMIDT,"WP",9)="9^"_$S($O(^SRF(GMN,9,0)):"Yes",1:"No")
     62 S ^TMP("ORDATA",$J,GMIDT,"WP",10)="10^"_$G(DCTDTM) ; dictation time
     63 S ^TMP("ORDATA",$J,GMIDT,"WP",11)="11^"_$G(TRSDTM) ; transcription time
     64 ;
     65 ; surgeon's dictation
     66 I $D(^UTILITY($J,"W")) D  S ORMORE=1
     67 . K ^TMP("ORHSSRT",$J)
     68 . F GMI=1:1:^UTILITY($J,"W",DIWL) D
     69 .. S ^TMP("ORHSSRT",$J,GMIDT,"WP",GMI)=^UTILITY($J,"W",DIWL,GMI,0)
     70 . D SPMRG^ORDVU($NA(^TMP("ORHSSRT",$J,GMIDT,"WP")),$NA(^TMP("ORDATA",$J,GMIDT,"WP",12)),12)
     71 . K ^UTILITY($J,"W")
     72 . K ^TMP("ORHSSRT",$J)
     73 I ORMORE S ^TMP("ORDATA",$J,GMIDT,"WP",13)="13^[+]" ;flag for detail
     74 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06.m

    r613 r623  
    1 ORDV06  ; slc/dkm - OE/RR Report Extracts ;10/8/03  11:17
    2         ;;3.0;ORDER ENTRY RESULTS REPORTING;**109,118,167,208,215,274,243**;Dec 17, 1997;Build 242
    3         ;Pharmacy Extracts
    4 RXA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)     ;Active Outpatient Pharmacy
    5         ;Call to PSOHCSUM
    6         ;
    7         I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
    8         . N BEG,END,MAX
    9         . S BEG=0,END=9999999,MAX=9999
    10         . D GCPR^OMGCOAS1(DFN,"RXA",BEG,END,MAX)
    11         ;
    12         N ORRXSTAT,GO,PSOACT
    13         Q:'$L(OREXT)
    14         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    15         Q:'$L($T(@GO))
    16         S PSOACT=1,ORRXSTAT="^ACTIVE^ACTIVE/SUSP^"
    17         D GET
    18         Q
    19 RXOP(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)    ;All Outpatient Pharmacy
    20         ;Call to PSOHCSUM
    21         ;
    22         I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
    23         . N BEG,END,MAX
    24         . S BEG=0,END=9999999,MAX=9999
    25         . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX)
    26         ;
    27         N ORRXSTAT,GO
    28         Q:'$L(OREXT)
    29         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    30         Q:'$L($T(@GO))
    31         S ORRXSTAT=""
    32         D GET
    33         Q
    34 GET     N J,ORDT,ORI,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG
    35         N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
    36         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    37         S PSOBEGIN=0
    38         K ^TMP("ORDATA",$J)
    39         I '$L($T(GCPR^OMGCOAS1)) D
    40         . K ^TMP("PSOO",$J)
    41         . D @GO
    42         S (ORDT,ORI)=0
    43         F  S ORDT=$O(^TMP("PSOO",$J,ORDT)) Q:(ORDT'>0)  S ORX0=$G(^(ORDT,0)) I ORX0'="" D
    44         . I $L(ORRXSTAT),ORRXSTAT'[(U_$P($P(ORX0,U,5),";",2)) Q  ;Check status
    45         . S ORI=ORI+1
    46         . S SITE=$S($L($G(^TMP("PSOO",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
    47         . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID
    48         . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),";",2) ;Drug Name
    49         . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";") ;Drug IEN
    50         . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;RX #
    51         . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status
    52         . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(ORX0,U,7) ;Quantity
    53         . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,11)) ;Exp/Cancel Date
    54         . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$$DATE^ORDVU($P(ORX0,U)) ;Issue Date
    55         . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Last Fill Date
    56         . S ^TMP("ORDATA",$J,ORDT,"WP",10)="10^"_$P(ORX0,U,8) ;#Refills
    57         . S ^TMP("ORDATA",$J,ORDT,"WP",11)="11^"_$P($P(ORX0,U,4),";",2) ;Provider
    58         . S ^TMP("ORDATA",$J,ORDT,"WP",12)="12^"_$P(ORX0,U,10) ;Cost-fill
    59         . S ^TMP("ORDATA",$J,ORDT,"WP",15)="15^"_$P(ORX0,U,9) ;PharmID
    60         . S ^TMP("ORDATA",$J,ORDT,"WP",16)="16^"_$P(ORX0,U,11) ;Order Number
    61         . S J=0
    62         . F  S J=$O(^TMP("PSOO",$J,ORDT,J)) Q:'J  D
    63         ..S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",14,J)="14^"_X
    64         K ^TMP("PSOO",$J)
    65         S ROOT=$NA(^TMP("ORDATA",$J))
    66         Q
    67 RXAV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)    ;Active IV Pharmacy
    68         ;Call to ENHS^PSJEEU0
    69         N ORIVSTAT,GO
    70         Q:'$L(OREXT)
    71         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    72         Q:'$L($T(@GO))
    73         S ORIVSTAT="^ACTIVE^"
    74         D GET1
    75         Q
    76 RXIV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)    ;  All IV Pharmcy
    77         ;Call to ENHS^PSJEEU0
    78         N ORIVSTAT,GO
    79         Q:'$L(OREXT)
    80         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    81         Q:'$L($T(@GO))
    82         S ORIVSTAT=""
    83         D GET1
    84         Q
    85 GET1    N ORDT,ORI,ORX0,ORIDRG,ORDRGIEN,ORDRG,ORDOSE,ORREC,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,ORWII,ORMORE
    86         N GMI,GMTSIDT,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,TN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
    87         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    88         S PSJEDT=1,PSJNKF=1
    89         K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
    90         D @GO
    91         S ORDT=-9999999,ORI=0
    92         F  S ORDT=$O(^UTILITY("PSIV",$J,ORDT)) Q:(ORDT="")  S ORX0=$G(^(ORDT,0)) I ORX0'="" D
    93         . I $L(ORIVSTAT),ORIVSTAT'[(U_$P($P(ORX0,U,4),";",2)_U) Q  ;Check status
    94         . S ORMORE=0,SITE=$S($L($G(^UTILITY("PSIV",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
    95         . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE  ;Station ID
    96         . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U))  ;Start Date
    97         . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2))  ;Stop Date
    98         . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,5)  ;Rate
    99         . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P(ORX0,U,6)  ;Schedule JEH
    100         . S ORIDRG=0
    101         . F  S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"A",ORIDRG)) Q:'ORIDRG  S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D  ;Additives
    102         .. S ^TMP("ORDATA",$J,ORDT,"WP",2,ORIDRG)="2^"_$P($P(ORREC,U),";",2)_"  "_$P(ORREC,U,2) ;Additive  Dose
    103         . S ORIDRG=0
    104         . F  S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"S",ORIDRG)) Q:'ORIDRG  S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D  ;Solutions
    105         .. S ^TMP("ORDATA",$J,ORDT,"WP",3,ORIDRG)="3^"_$P($P(ORREC,U),";",2)_"  "_$P(ORREC,U,2) ;Solution  Dose
    106         . I ORMORE S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^[+]" ;flag for detail
    107         K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
    108         S ROOT=$NA(^TMP("ORDATA",$J))
    109         Q
    110 RXUD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)    ;  Get Unit Dose Pharmacy Component
    111         ;Call to ENHS^PSJEEU0
    112         N J,ORDT,ORI,ORX0,ORDRGIEN,ORDRG,ORDOSE,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,GO
    113         N GMI,IX,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,GMR,TN,UDS,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
    114         Q:'$L(OREXT)
    115         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    116         Q:'$L($T(@GO))
    117         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    118         S PSJEDT=1,PSJNKF=1
    119         K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
    120         D @GO
    121         S ORDT=-9999999,ORI=0
    122         F  S ORDT=$O(^UTILITY("PSG",$J,ORDT)) Q:(ORDT="")  S ORX0=$G(^(ORDT)) I ORX0'="" D
    123         . S SITE=$S($L($G(^UTILITY("PSG",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
    124         . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE  ;Station ID
    125         . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),":")  ;DRUG IEN
    126         . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";",2)  ;Drug Name
    127         . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6)  ;Dose
    128         . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2)  ;Status
    129         . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U))  ;START Date
    130         . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2))  ;Stop Date
    131         . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P($P(ORX0,U,7),";",3)  ;Route
    132         . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$P(ORX0,U,8)  ;SIG
    133         K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
    134         S ROOT=$NA(^TMP("ORDATA",$J))
    135         Q
     1ORDV06 ; slc/dkm - OE/RR Report Extracts ;10/8/03  11:17
     2 ;;3.0;ORDER ENTRY RESULTS REPORTING;**109,118,167,208,215,274**;Dec 17, 1997;Build 20
     3 ;Pharmacy Extracts
     4RXA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active Outpatient Pharmacy
     5 ;Call to PSOHCSUM
     6 ;
     7 I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
     8 . N BEG,END,MAX
     9 . S BEG=0,END=9999999,MAX=9999
     10 . D GCPR^OMGCOAS1(DFN,"RXA",BEG,END,MAX)
     11 ;
     12 N ORRXSTAT,GO,PSOACT
     13 Q:'$L(OREXT)
     14 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     15 Q:'$L($T(@GO))
     16 S PSOACT=1,ORRXSTAT="^ACTIVE^ACTIVE/SUSP^"
     17 D GET
     18 Q
     19RXOP(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy
     20 ;Call to PSOHCSUM
     21 ;
     22 I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
     23 . N BEG,END,MAX
     24 . S BEG=0,END=9999999,MAX=9999
     25 . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX)
     26 ;
     27 N ORRXSTAT,GO
     28 Q:'$L(OREXT)
     29 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     30 Q:'$L($T(@GO))
     31 S ORRXSTAT=""
     32 D GET
     33 Q
     34GET N J,ORDT,ORI,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG
     35 N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
     36 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     37 S PSOBEGIN=0
     38 K ^TMP("ORDATA")
     39 I '$L($T(GCPR^OMGCOAS1)) D
     40 . K ^TMP("PSOO",$J)
     41 . D @GO
     42 S (ORDT,ORI)=0
     43 F  S ORDT=$O(^TMP("PSOO",$J,ORDT)) Q:(ORDT'>0)  S ORX0=$G(^(ORDT,0)) I ORX0'="" D
     44 . I $L(ORRXSTAT),ORRXSTAT'[(U_$P($P(ORX0,U,5),";",2)) Q  ;Check status
     45 . S ORI=ORI+1
     46 . S SITE=$S($L($G(^TMP("PSOO",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
     47 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID
     48 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),";",2) ;Drug Name
     49 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";") ;Drug IEN
     50 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;RX #
     51 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status
     52 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(ORX0,U,7) ;Quantity
     53 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,11)) ;Exp/Cancel Date
     54 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$$DATE^ORDVU($P(ORX0,U)) ;Issue Date
     55 . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Last Fill Date
     56 . S ^TMP("ORDATA",$J,ORDT,"WP",10)="10^"_$P(ORX0,U,8) ;#Refills
     57 . S ^TMP("ORDATA",$J,ORDT,"WP",11)="11^"_$P($P(ORX0,U,4),";",2) ;Provider
     58 . S ^TMP("ORDATA",$J,ORDT,"WP",12)="12^"_$P(ORX0,U,10) ;Cost-fill
     59 . S ^TMP("ORDATA",$J,ORDT,"WP",15)="15^"_$P(ORX0,U,9) ;PharmID
     60 . S ^TMP("ORDATA",$J,ORDT,"WP",16)="16^"_$P(ORX0,U,11) ;Order Number
     61 . S J=0
     62 . F  S J=$O(^TMP("PSOO",$J,ORDT,J)) Q:'J  S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",14,J)="14^"_X
     63 . I $O(^TMP("PSOO",$J,ORDT,1)) S ^TMP("ORDATA",$J,ORDT,"WP",13)="13^[+]" ;flag for detail
     64 K ^TMP("PSOO",$J)
     65 S ROOT=$NA(^TMP("ORDATA",$J))
     66 Q
     67RXAV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active IV Pharmacy
     68 ;Call to ENHS^PSJEEU0
     69 N ORIVSTAT,GO
     70 Q:'$L(OREXT)
     71 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     72 Q:'$L($T(@GO))
     73 S ORIVSTAT="^ACTIVE^"
     74 D GET1
     75 Q
     76RXIV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;  All IV Pharmcy
     77 ;Call to ENHS^PSJEEU0
     78 N ORIVSTAT,GO
     79 Q:'$L(OREXT)
     80 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     81 Q:'$L($T(@GO))
     82 S ORIVSTAT=""
     83 D GET1
     84 Q
     85GET1 N ORDT,ORI,ORX0,ORIDRG,ORDRGIEN,ORDRG,ORDOSE,ORREC,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,ORWII,ORMORE
     86 N GMI,GMTSIDT,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,TN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
     87 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     88 S PSJEDT=1,PSJNKF=1
     89 K ^TMP("ORDATA"),^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
     90 D @GO
     91 S ORDT=-9999999,ORI=0
     92 F  S ORDT=$O(^UTILITY("PSIV",$J,ORDT)) Q:(ORDT="")  S ORX0=$G(^(ORDT,0)) I ORX0'="" D
     93 . I $L(ORIVSTAT),ORIVSTAT'[(U_$P($P(ORX0,U,4),";",2)_U) Q  ;Check status
     94 . S ORMORE=0,SITE=$S($L($G(^UTILITY("PSIV",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
     95 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE  ;Station ID
     96 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U))  ;Start Date
     97 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$$DATE^ORDVU($P(ORX0,U,2))  ;Stop Date
     98 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,5)  ;Rate
     99 . S ORIDRG=0
     100 . F  S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"A",ORIDRG)) Q:'ORIDRG  S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D  ;Additives
     101 .. S ^TMP("ORDATA",$J,ORDT,"WP",5,ORIDRG)="5^"_$P($P(ORREC,U),";",2)_"  "_$P(ORREC,U,2) ;Additive  Dose
     102 . S ORIDRG=0
     103 . F  S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"S",ORIDRG)) Q:'ORIDRG  S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D  ;Solutions
     104 .. S ^TMP("ORDATA",$J,ORDT,"WP",6,ORIDRG)="6^"_$P($P(ORREC,U),";",2)_"  "_$P(ORREC,U,2) ;Solution  Dose
     105 . I ORMORE S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^[+]" ;flag for detail
     106 K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
     107 S ROOT=$NA(^TMP("ORDATA",$J))
     108 Q
     109RXUD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;  Get Unit Dose Pharmacy Component
     110 ;Call to ENHS^PSJEEU0
     111 N J,ORDT,ORI,ORX0,ORDRGIEN,ORDRG,ORDOSE,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,GO
     112 N GMI,IX,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,GMR,TN,UDS,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
     113 Q:'$L(OREXT)
     114 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     115 Q:'$L($T(@GO))
     116 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     117 S PSJEDT=1,PSJNKF=1
     118 K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
     119 D @GO
     120 S ORDT=-9999999,ORI=0
     121 F  S ORDT=$O(^UTILITY("PSG",$J,ORDT)) Q:(ORDT="")  S ORX0=$G(^(ORDT)) I ORX0'="" D
     122 . S SITE=$S($L($G(^UTILITY("PSG",$J,ORDT,"facility"))):^("facility"),1:ORSITE)
     123 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE  ;Station ID
     124 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),":")  ;DRUG IEN
     125 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";",2)  ;Drug Name
     126 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6)  ;Dose
     127 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2)  ;Status
     128 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U))  ;START Date
     129 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2))  ;Stop Date
     130 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P($P(ORX0,U,7),";",3)  ;Route
     131 . S J=0,ORI=ORI+1
     132 . F  S J=$O(^UTILITY("PSG",$J,ORDT,J)) Q:'J  S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X ;SIG
     133 . I $O(^UTILITY("PSG",$J,ORDT,1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail
     134 K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J)
     135 S ROOT=$NA(^TMP("ORDATA",$J))
     136 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06A.m

    r613 r623  
    1 ORDV06A ; slc/dcm - OE/RR Report Extracts ;3/8/04  11:17
    2         ;;3.0;ORDER ENTRY RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;Pharmacy Extracts
    4 NVA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)     ;All Outpatient Pharmacy
    5         ;Call to PSOHCSUM
    6         ;^TMP("PSOO",$J,"NVA",n,0)=Herbal/OTC/Non VA Medication^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100)
    7         ;                          ^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format)
    8         ;^TMP("PSOO",$J,"NVA",n,1,0)=dosage^med route^schedule (previous 3 fields are Instructions)^drug (file #50_";"_.01)^clinic (file #44_";"_.01)
    9         ;^TMP("PSOO",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments
    10         I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
    11         . N BEG,END,MAX
    12         . S BEG=0,END=9999999,MAX=9999
    13         . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX)
    14         ;
    15         N GO
    16         Q:'$L(OREXT)
    17         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    18         Q:'$L($T(@GO))
    19         D GET
    20         Q
    21 GET     N J,ORDT,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG,ORX0,ORX1
    22         N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
    23         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    24         S PSOBEGIN=0
    25         K ^TMP("ORDATA",$J)
    26         I '$L($T(GCPR^OMGCOAS1)) D
    27         . K ^TMP("PSOO",$J)
    28         . D @GO
    29         S ORDT=0
    30         F  S ORDT=$O(^TMP("PSOO",$J,"NVA",ORDT)) Q:(ORDT'>0)  S ORX0=$G(^(ORDT,0)) I ORX0'="" S ORX1=$G(^(1,0)) D
    31         . S SITE=$S($L($G(^TMP("PSOO",$J,"NVA",ORDT,"facility"))):^("facility"),1:ORSITE)
    32         . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID
    33         . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P(ORX0,U) ;Herbal/OTC/Non VA Medication
    34         . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P(ORX0,U,2) ;Status
    35         . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,U,3)) ;Start Date
    36         . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,U,5)) ;Date Documented
    37         . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P($P(ORX0,U,6),";",2) ;Documented By
    38         . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,7)) ;Date DC'd
    39         . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P(ORX1,U)_" "_$P(ORX1,U,2)_" "_$P(ORX1,U,3) ;SIG dose + route + schedule
    40         . S J=0
    41         . F  S J=$O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",J)) Q:'J  S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X
    42         . I $O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail
    43         K ^TMP("PSOO",$J)
    44         S ROOT=$NA(^TMP("ORDATA",$J))
    45         Q
     1ORDV06A ; slc/dcm - OE/RR Report Extracts ;3/8/04  11:17
     2 ;;3.0;ORDER ENTRY RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;Pharmacy Extracts
     4NVA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy
     5 ;Call to PSOHCSUM
     6 ;^TMP("PSOO",$J,"NVA",n,0)=Herbal/OTC/Non VA Medication^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100)
     7 ;                          ^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format)
     8 ;^TMP("PSOO",$J,"NVA",n,1,0)=dosage^med route^schedule (previous 3 fields are Instructions)^drug (file #50_";"_.01)^clinic (file #44_";"_.01)
     9 ;^TMP("PSOO",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments
     10 I $L($T(GCPR^OMGCOAS1)) D  ; Call if FHIE station 200
     11 . N BEG,END,MAX
     12 . S BEG=0,END=9999999,MAX=9999
     13 . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX)
     14 ;
     15 N GO
     16 Q:'$L(OREXT)
     17 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     18 Q:'$L($T(@GO))
     19 D GET
     20 Q
     21GET N J,ORDT,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG,ORX0,ORX1
     22 N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE
     23 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     24 S PSOBEGIN=0
     25 K ^TMP("ORDATA")
     26 I '$L($T(GCPR^OMGCOAS1)) D
     27 . K ^TMP("PSOO",$J)
     28 . D @GO
     29 S ORDT=0
     30 F  S ORDT=$O(^TMP("PSOO",$J,"NVA",ORDT)) Q:(ORDT'>0)  S ORX0=$G(^(ORDT,0)) I ORX0'="" S ORX1=$G(^(1,0)) D
     31 . S SITE=$S($L($G(^TMP("PSOO",$J,"NVA",ORDT,"facility"))):^("facility"),1:ORSITE)
     32 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID
     33 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P(ORX0,U) ;Herbal/OTC/Non VA Medication
     34 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P(ORX0,U,2) ;Status
     35 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,U,3)) ;Start Date
     36 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,U,5)) ;Date Documented
     37 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P($P(ORX0,U,6),";",2) ;Documented By
     38 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,7)) ;Date DC'd
     39 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P(ORX1,U)_" "_$P(ORX1,U,2)_" "_$P(ORX1,U,3) ;SIG dose + route + schedule
     40 . S J=0
     41 . F  S J=$O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",J)) Q:'J  S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X
     42 . I $O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail
     43 K ^TMP("PSOO",$J)
     44 S ROOT=$NA(^TMP("ORDATA",$J))
     45 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV08.m

    r613 r623  
    1 ORDV08  ;DAN/SLC Testing new component ;8/22/01  11:30
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,243**;Dec 17,1997;Build 242
    3         ;
    4 RIM(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)            ;Radiology report
    5         ;External Calls: MAIN^GMTSRAE(2),RPT^ORWRA
    6         N ORX0,ORCNT,ORSITE,SITE,GO,ORMORE,ORROOT
    7         Q:'$L(OREXT)
    8         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    9         Q:'$L($T(@GO))
    10         K ^TMP("ORDATA",$J),^TMP("ORXPND",$J)
    11         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    12         D @GO
    13         S ORCNT=0
    14         F  S ORCNT=$O(^TMP($J,"ORAEXAMS",ORCNT)) Q:'ORCNT  D
    15         . S ORMORE=0
    16         . S ORX0=$G(^TMP($J,"ORAEXAMS",ORCNT))
    17         . D RPT^ORWRA(.ORROOT,DFN,$P(ORX0,U))
    18         . S SITE=$S($L($G(^TMP($J,"ORAEXAMS",ORCNT,"facility"))):^("facility"),1:ORSITE)
    19         . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID
    20         . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U,2)) ;date
    21         . S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,3) ;procedure
    22         . S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,5) ;report status
    23         . S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,4) ;Case #
    24         . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history
    25         . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",7)="7^[+]" ;flag for detail
    26         . S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^"_$P(ORX0,U,14) ;Image available
    27         . S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^"_"i"_$P(ORX0,U,1)  ;EXAM ID
    28         K ^TMP("RAE",$J),^TMP("ORXPND",$J)
    29         S ROOT=$NA(^TMP("ORDATA",$J))
    30         Q
    31         ;
    32 IGET    ;Get imaging exams
    33         N ORROOT,ORRADATA,I,ID
    34         S ORRADATA=$NA(^TMP($J,"RAE1",DFN))
    35         S ORROOT=$NA(^TMP($J,"ORAEXAMS"))
    36         K @ORRADATA,@ORROOT
    37         D EN1^RAO7PC1(DFN,ORDBEG,ORDEND,ORMAX) ;call to Radiology to get exams
    38         S I=0,ID=""
    39         F  S ID=$O(@ORRADATA@(ID)) Q:ID=""  D
    40         . S I=I+1
    41         . S @ORROOT@(I)=ID_U_(9999999.9999-ID)_U_@ORRADATA@(ID)
    42         K @ORRADATA
    43         Q
    44         ;
    45 MPRO(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)    ;Medicine Procedures
    46         N ORSITE,ORI,ORREC,ORMORE,ORDATE,SITE,ORARRAY,ORPROC,ORSUM
    47         Q:'$L(OREXT)
    48         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    49         Q:'$L($T(@GO))
    50         K ^TMP("ORDATA",$J),^TMP("ORTEMP",$J),^TMP("MCAR",$J)
    51         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    52         D @GO
    53         S ORI=0
    54         F  S ORI=$O(^TMP("MCAR",$J,ORI)) Q:'ORI!(ORI>ORMAX)  D
    55         .K ^TMP("ORTEMP",$J) D GETREC^ORDV08A(ORI,80,20,56,3)
    56         .S SITE=$S($L($G(^TMP("MCAR",$J,ORI,"facility"))):^("facility"),1:ORSITE)
    57         .S ^TMP("ORDATA",$J,ORI,"WP",1)="1^"_SITE ;Site ID
    58         .S ^TMP("ORDATA",$J,ORI,"WP",2)="2^"_$$DATEMMM^ORDVU(ORDATE) ;Procedure date/time
    59         .S ^TMP("ORDATA",$J,ORI,"WP",3)="3^"_ORPROC ;Procedure Name
    60         .S ^TMP("ORDATA",$J,ORI,"WP",4)="4^"_$S(ORSUM'="":ORSUM,1:"No Summary") ;Summary
    61         .I $D(^TMP("ORTEMP",$J)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORTEMP",$J)),$NA(^TMP("ORDATA",$J,ORI,"WP",5,1)),5) ;Detailed Report
    62         .I ORMORE S ^TMP("ORDATA",$J,ORI,"WP",6)="6^[+]" ;Detailed report flag
    63         .Q
    64         K ^TMP("ORTEMP",$J),^TMP("MCAR",$J)
    65         S ROOT=$NA(^TMP("ORDATA",$J))
    66         Q
    67 MGET    ;Get medicine results
    68         D HSUM^GMTSMCMA(DFN,ORDBEG,ORDEND,ORMAX,"","F")
    69         Q
    70 DIETNS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)  ;Nutrition assessment
    71         ;External Calls:SITE^VASITE, NUTR^ORWRP1, LISTNUTR^ORWPR1,FMTE^XLFDT
    72         N ORSITE,ORARRAY,ORID,ORCNT,ORMORE,GO,ORDT
    73         Q:'$L(OREXT)
    74         S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
    75         Q:'$L($T(@GO))
    76         K ^TMP("ORDATA",$J),^TMP("ORXPND",$J)
    77         S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
    78         D @GO
    79         S ORCNT=0,ORDT=OROMEGA
    80         F  S ORDT=$O(^TMP($J,"FHADT",DFN,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(ORCNT>ORMAX)  D
    81         . S ORID=$$FMTE^XLFDT(9999999-ORDT,2) ;convert inverse date to external date
    82         . S ORCNT=ORCNT+1,ORMORE=0
    83         . D NUTR^ORWRP1(.ORARRAY,DFN,ORID)
    84         . S ORSITE=$S($L($G(^TMP($J,"FHADT",ORDT,"facility"))):^("facility"),1:ORSITE)
    85         . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_ORSITE ;Site ID
    86         . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_ORID ;assessment date/time
    87         . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",3,1)),3) ;assessment report
    88         . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^[+]" ;flag for detail
    89         K ^TMP($J,"FHADT"),^TMP("ORXPND",$J)
    90         S ROOT=$NA(^TMP("ORDATA",$J))
    91         Q
    92         ;
    93 GETNS   ;Get nutritional assessments
    94         D LISTNUTR^ORWRP1(.ORARRAY,DFN)
    95         Q
     1ORDV08 ;DAN/SLC Testing new component ;8/22/01  11:30
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120**;Dec 17,1997
     3 ;
     4RIM(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT)        ;Radiology report
     5 ;External Calls: MAIN^GMTSRAE(2),RPT^ORWRA
     6 N ORX0,ORCNT,ORSITE,SITE,GO,ORMORE,ORROOT
     7 Q:'$L(OREXT)
     8 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     9 Q:'$L($T(@GO))
     10 K ^TMP("ORDATA",$J),^TMP("ORXPND",$J)
     11 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     12 D @GO
     13 S ORCNT=0
     14 F  S ORCNT=$O(^TMP($J,"ORAEXAMS",ORCNT)) Q:'ORCNT  D
     15 . S ORMORE=0
     16 . S ORX0=$G(^TMP($J,"ORAEXAMS",ORCNT))
     17 . D RPT^ORWRA(.ORROOT,DFN,$P(ORX0,U))
     18 . S SITE=$S($L($G(^TMP($J,"ORAEXAMS",ORCNT,"facility"))):^("facility"),1:ORSITE)
     19 . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID
     20 . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U,2)) ;date
     21 . S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,3) ;procedure
     22 . S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,5) ;report status
     23 . S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,4) ;Case #
     24 . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history
     25 . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",7)="7^[+]" ;flag for detail
     26 . S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^"_$P(ORX0,U,14) ;Image available
     27 K ^TMP("RAE",$J),^TMP("ORXPND",$J)
     28 S ROOT=$NA(^TMP("ORDATA",$J))
     29 Q
     30 ;
     31IGET ;Get imaging exams
     32 N ORROOT,ORRADATA,I,ID
     33 S ORRADATA=$NA(^TMP($J,"RAE1",DFN))
     34 S ORROOT=$NA(^TMP($J,"ORAEXAMS"))
     35 K @ORRADATA,@ORROOT
     36 D EN1^RAO7PC1(DFN,ORDBEG,ORDEND,ORMAX) ;call to Radiology to get exams
     37 S I=0,ID=""
     38 F  S ID=$O(@ORRADATA@(ID)) Q:ID=""  D
     39 . S I=I+1
     40 . S @ORROOT@(I)=ID_U_(9999999.9999-ID)_U_@ORRADATA@(ID)
     41 K @ORRADATA
     42 Q
     43 ;
     44MPRO(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Medicine Procedures
     45 N ORSITE,ORI,ORREC,ORMORE,ORDATE,SITE,ORARRAY,ORPROC,ORSUM
     46 Q:'$L(OREXT)
     47 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     48 Q:'$L($T(@GO))
     49 K ^TMP("ORDATA",$J),^TMP("ORTEMP",$J),^TMP("MCAR",$J)
     50 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     51 D @GO
     52 S ORI=0
     53 F  S ORI=$O(^TMP("MCAR",$J,ORI)) Q:'ORI!(ORI>ORMAX)  D
     54 .K ^TMP("ORTEMP",$J) D GETREC^ORDV08A(ORI,80,20,56,3)
     55 .S SITE=$S($L($G(^TMP("MCAR",$J,ORI,"facility"))):^("facility"),1:ORSITE)
     56 .S ^TMP("ORDATA",$J,ORI,"WP",1)="1^"_SITE ;Site ID
     57 .S ^TMP("ORDATA",$J,ORI,"WP",2)="2^"_$$DATEMMM^ORDVU(ORDATE) ;Procedure date/time
     58 .S ^TMP("ORDATA",$J,ORI,"WP",3)="3^"_ORPROC ;Procedure Name
     59 .S ^TMP("ORDATA",$J,ORI,"WP",4)="4^"_$S(ORSUM'="":ORSUM,1:"No Summary") ;Summary
     60 .I $D(^TMP("ORTEMP",$J)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORTEMP",$J)),$NA(^TMP("ORDATA",$J,ORI,"WP",5,1)),5) ;Detailed Report
     61 .I ORMORE S ^TMP("ORDATA",$J,ORI,"WP",6)="6^[+]" ;Detailed report flag
     62 .Q
     63 K ^TMP("ORTEMP",$J),^TMP("MCAR",$J)
     64 S ROOT=$NA(^TMP("ORDATA",$J))
     65 Q
     66MGET ;Get medicine results
     67 D HSUM^GMTSMCMA(DFN,ORDBEG,ORDEND,ORMAX,"","F")
     68 Q
     69DIETNS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Nutrition assessment
     70 ;External Calls:SITE^VASITE, NUTR^ORWRP1, LISTNUTR^ORWPR1,FMTE^XLFDT
     71 N ORSITE,ORARRAY,ORID,ORCNT,ORMORE,GO,ORDT
     72 Q:'$L(OREXT)
     73 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2)
     74 Q:'$L($T(@GO))
     75 K ^TMP("ORDATA",$J),^TMP("ORXPND",$J)
     76 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
     77 D @GO
     78 S ORCNT=0,ORDT=OROMEGA
     79 F  S ORDT=$O(^TMP($J,"FHADT",DFN,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(ORCNT>ORMAX)  D
     80 . S ORID=$$FMTE^XLFDT(9999999-ORDT,2) ;convert inverse date to external date
     81 . S ORCNT=ORCNT+1,ORMORE=0
     82 . D NUTR^ORWRP1(.ORARRAY,DFN,ORID)
     83 . S ORSITE=$S($L($G(^TMP($J,"FHADT",ORDT,"facility"))):^("facility"),1:ORSITE)
     84 . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_ORSITE ;Site ID
     85 . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_ORID ;assessment date/time
     86 . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",3,1)),3) ;assessment report
     87 . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^[+]" ;flag for detail
     88 K ^TMP($J,"FHADT"),^TMP("ORXPND",$J)
     89 S ROOT=$NA(^TMP("ORDATA",$J))
     90 Q
     91 ;
     92GETNS ;Get nutritional assessments
     93 D LISTNUTR^ORWRP1(.ORARRAY,DFN)
     94 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX.m

    r613 r623  
    1 OREVNTX ; SLC/MKB - Event delayed orders RPC's ; 5/4/07 11:34am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242
    3         ;
    4 PAT(ORY,DFN)       ; -- Returns currently delayed events for patient DFN
    5         N EVT,CNT,X,Y S DFN=+$G(DFN),(EVT,CNT)=0
    6         F  S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1  S Y=+$O(^(EVT,0)) D
    7         . I $G(^ORE(100.2,Y,1)) K ^ORE(100.2,"AE",DFN,EVT,Y) Q
    8         . Q:$$LAPSED(Y)  ;I $$EMPTY(Y) D CANCEL(Y) Q
    9         . Q:$O(^ORE(100.2,"DAD",Y,0))  ;has children
    10         . S X=$P($G(^ORD(100.5,EVT,0)),U,8),X="Delayed "_$$LOWER^VALM1(X)
    11         . S CNT=CNT+1,ORY(CNT)=Y_U_X
    12         S:CNT ORY(0)=CNT
    13         Q
    14         ;
    15 EXISTS(DFN,EVT) ; -- Returns 1 if patient DFN has delayed orders for EVT,
    16         ;    or 2 if parent/sibling event has delayed orders, else 0
    17         ;
    18         N X,Y,I S Y=0 I '$G(DFN)!'$G(EVT) G EXQ
    19         I $O(^ORE(100.2,"AE",+DFN,+EVT,0)) S Y=1 G EXQ
    20         S X=+$P($G(^ORD(100.5,+EVT,0)),U,12) I X D  G EXQ ;ck parent,siblings
    21         . I $O(^ORE(100.2,"AE",+DFN,X,0)) S Y=2 Q
    22         . S I=0 F  S I=+$O(^ORD(100.5,"DAD",X,I)) Q:I<1  I $O(^ORE(100.2,"AE",+DFN,I,0)) S Y=2 Q
    23 EXQ     Q Y
    24         ;
    25 LIST(ORY,DFN)     ; -- Returns all processed events for patient DFN as
    26         ;    ORY(#) = PatEvtIEN ^ Display Text ^ EvtDateTime
    27         ;             in reverse chronological order
    28         N IDT,DA,CNT,X0,X1,EVT,DC,X
    29         S DFN=+$G(DFN),(IDT,CNT)=0
    30         F  S IDT=$O(^ORE(100.2,"AC",DFN,IDT)) Q:IDT<1  D
    31         . S DA=0 F  S DA=+$O(^ORE(100.2,"AC",DFN,IDT,DA)) Q:DA<1  D
    32         .. S X0=$G(^ORE(100.2,DA,0)),X1=$G(^(1)) Q:$P(X1,U,5)  ;has parent
    33         .. S EVT=+$P(X0,U,2),DC=+$P(X1,U,3)
    34         .. I '$P(X0,U,4),'$O(^ORE(100.2,DA,2,0)),'$O(^ORE(100.2,DA,3,0)),'$D(^OR(100,"AEVNT",DFN_";DPT(",DA)) Q  ;no orders
    35         .. S I=+$O(^ORE(100.2,DA,10,"B"),-1),X=$P($G(^(I,0)),U,2) I X="LP"!(X="CA") Q  ;lapsed or cancelled
    36         .. ;Q if not current admission?
    37         .. S X=$S(EVT:$P($G(^ORD(100.5,EVT,0)),U,8),DC:$P($G(^ORD(100.6,DC,0)),U,5),1:"UNSPECIFIED EVENT")
    38         .. S X=$$LOWER^VALM1(X),CNT=CNT+1,ORY(CNT)=DA_U_X_U_$P(X1,U)
    39         S:CNT ORY(0)=CNT
    40         Q
    41         ;
    42 COMP(PTEVT)     ; -- Returns 1 or 0, if PTEVT has been completed
    43         N Y,I S Y=$S($G(^ORE(100.2,+$G(PTEVT),1)):1,1:0)
    44         I Y S I=+$O(^ORE(100.2,+$G(PTEVT),10,0)) S:$P($G(^(I,0)),U,2)="CA" Y=0
    45         Q Y
    46         ;
    47 ACTIVE(ORY,TYPE)            ; -- Returns all active events [of TYPE] from #100.5
    48         ;  where TYPE=string containing any of the codes from the TYPE field
    49         N NM,IEN,CNT,X0,X S CNT=0,TYPE=$G(TYPE)
    50         S NM="" F  S NM=$O(^ORD(100.5,"C",NM)) Q:NM=""  D
    51         . S IEN=0 F  S IEN=+$O(^ORD(100.5,"C",NM,IEN)) Q:IEN<1  D
    52         .. S X0=$G(^ORD(100.5,IEN,0)) I '$L($P(X0,U,2)) D  ;Child event
    53         ... S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2)
    54         .. I $L(TYPE),TYPE'[$P(X0,U,2) Q
    55         .. Q:$O(^ORD(100.5,"DAD",IEN,0))  ;Parent event
    56         .. S CNT=CNT+1,ORY(CNT)=IEN_U_X0
    57         S:CNT ORY(0)=CNT
    58         Q
    59         ;
    60 NAME(PTEVT)         ; -- Return name of Patient Event
    61         N X,Y,Z S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2),Z=$G(^(1))
    62         S:X Y=$P($G(^ORD(100.5,X,0)),U,8)
    63         I 'X S X=+$P(Z,U,3),Y=$P($G(^ORD(100.6,X,0)),U,5)
    64         S Y=$S('Z:"Delayed ",1:"")_$$LOWER^VALM1(Y)
    65         Q Y
    66         ;
    67 SHORTNM(PTEVT)   ; -- Return Short Name of Patient Event
    68         ;   or first 15 characters of Event Name if unspecified
    69         N X,Y,Y0 S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) I X D
    70         . S Y0=$G(^ORD(100.5,X,0)),Y=$P(Y0,U,10)
    71         . S:'$L(Y) Y=$E($P(Y0,U,8),1,15)
    72         I 'X S X=+$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3),Y=$E($P($G(^ORD(100.6,X,0)),U,5),1,15)
    73         Q Y
    74         ;
    75 EVT(PTEVT)           ; -- Return Event ptr #100.5, given PTEVT ptr #100.2
    76         Q +$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
    77         ;
    78 DC(PTEVT)       ; -- Return DC Rule ptr #100.6, given PTEVT ptr #100.2
    79         I $P($G(^ORE(100.2,+$G(PTEVT),1)),U,5) S PTEVT=$P(^(1),U,5) ;use parent
    80         Q +$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3)
    81         ;
    82 TYPE(PTEVT)         ; -- Return Type of Patient Event (i.e. A/D/T)
    83         N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
    84         I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent
    85         S Y=$S(X:$P($G(^ORD(100.5,X,0)),U,2),1:"DC")
    86         Q Y
    87         ;
    88 DIV(PTEVT)           ; -- Return Division for PTEVT
    89         N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
    90         I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent
    91         S Y=+$P($G(^ORD(100.5,X,0)),U,3) S:Y<1 Y=+$G(DUZ(2))
    92         Q Y
    93         ;
    94 LOC(PTEVT)           ; -- Return Default Ordering Location for PTEVT
    95         N X,X0,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
    96         S X0=$G(^ORD(100.5,X,0)),Y=+$P(X0,U,9)_";SC("
    97         I Y<1,$P(X0,U,12) S Y=+$P($G(^ORD(100.5,+$P(X0,U,12),0)),U,9)_";SC("
    98         S:Y<1 Y=$G(ORL)
    99         Q Y
    100         ;
    101 EMPTY(PTEVT)       ; -- Returns 1 or 0, if PTEVT has delayed orders
    102         N Y,OR0,PAT,TYPE,PSO,IFN,STS S Y=1 I '$G(PTEVT) Q Y
    103         S OR0=$G(^ORE(100.2,+PTEVT,0)),PAT=+$P(OR0,U)_";DPT("
    104         S TYPE=$$TYPE(PTEVT) I TYPE="D" S PSO=+$O(^DIC(9.4,"C","PSO",0))
    105         S IFN=0 F  S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1  D  Q:'Y
    106         . S STS=$P($G(^OR(100,IFN,3)),U,3) I STS=10 S Y=0 Q
    107         . ;I IFN=+$P(OR0,U,4),STS=11!(STS=6) S Y=0 Q
    108         . I TYPE="D",$P($G(^OR(100,IFN,0)),U,14)=PSO,STS=5!(STS=6) S Y=0 Q
    109         I Y,$D(^ORE(100.2,"DAD",PTEVT)) D  ;ck child events
    110         . N CHLD S CHLD=0
    111         . F  S CHLD=+$O(^ORE(100.2,"DAD",PTEVT,CHLD)) Q:CHLD<1  D  Q:'Y
    112         .. S IFN=0 F  S IFN=$O(^OR(100,"AEVNT",PAT,CHLD,IFN)) Q:IFN<1  I $P($G(^OR(100,IFN,3)),U,3)=10 S Y=0 Q
    113         Q Y
    114         ;
    115 EVTORDER(ORDER) ; -- Returns 1 or 0, if ORDER is for event
    116         ;    Will return 0 if action DA is included but not NW
    117         N X0,X,Y S X0=$G(^OR(100,+ORDER,0)),X=+$P(ORDER,";",2),Y=0
    118         I $P(X0,U,17),X'>1 D
    119         . I $P($G(^ORE(100.2,+$P(X0,U,17),0)),U,4)=+ORDER S Y=1 Q
    120         . S DAD=+$P($G(^ORE(100.2,+$P(X0,U,17),1)),U,5) ;has parent?
    121         . I DAD,$P($G(^ORE(100.2,DAD,0)),U,4)=+ORDER S Y=1
    122         Q Y
    123         ;
    124 MANREL(ORDER)     ; -- Returns 1 or 0, if ORDER was manually released
    125         N EVT,Y,RELDT,TYPE,EVTDT S Y=0
    126         S EVT=+$P($G(^OR(100,+ORDER,0)),U,17),RELDT=+$P($G(^(8,1,0)),U,16)
    127         G:EVT<1 MNQ G:RELDT<1 MNQ ;not delayed or released
    128         I '$D(^ORE(100.2,EVT,2,+ORDER)) S Y=1 G MNQ ;not rel'd by event
    129         S TYPE=$$TYPE(EVT),EVTDT=+$G(^ORE(100.2,EVT,1))
    130         I TYPE="M",$$FMDIFF^XLFDT(EVTDT,RELDT,2)<300 S Y=1
    131 MNQ     Q Y
    132         ;
    133 CANCEL(PTEVT)     ; -- Cancel empty PTEVT, event order
    134         S PTEVT=+$G(PTEVT) D DONE(PTEVT),ACTLOG(PTEVT,"CA")
    135         N IFN,DAD S IFN=+$P($G(^ORE(100.2,PTEVT,0)),U,4)
    136         I IFN<1 D  ;ck for parent w/event order
    137         . S DAD=+$P($G(^ORE(100.2,PTEVT,1)),U,5) Q:DAD<1
    138         . Q:'$G(^ORE(100.2,DAD,1))  ;parent still active
    139         . S IFN=+$P($G(^ORE(100.2,DAD,0)),U,4)
    140         I IFN D:'$$DCD^ORCACT2(IFN) CLRDLY^ORCACT2(IFN) ;cancel event order
    141         Q
    142         ;
    143 DONE(PTEVT,WHEN,MVT,OR)    ; -- Terminate PTEVT
    144         Q:'$G(PTEVT)  Q:'$D(^ORE(100.2,PTEVT,0))
    145         N X0,X1,PAT,EVT,DAD
    146         S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) D D1
    147         S DAD=$P(X1,U,5) I DAD,$$ALLDONE(DAD) S PTEVT=DAD D D1 Q
    148         S DAD=PTEVT,PTEVT=0 ;if PTEVT=parent, terminate children too
    149         F  S PTEVT=+$O(^ORE(100.2,"DAD",DAD,PTEVT)) Q:PTEVT<1  D D1
    150         Q
    151 D1      S X0=$G(^ORE(100.2,+PTEVT,0)),X1=$G(^(1)) Q:'$L(X0)
    152         S PAT=+$P(X0,U),EVT=+$P(X0,U,2) ;,ORD=+$P(X0,U,4)
    153         S $P(X1,U,1,2)=WHEN_U_$G(MVT),$P(X1,U,4)=$G(OR),^ORE(100.2,PTEVT,1)=X1
    154         S ^ORE(100.2,"AC",PAT,9999999-WHEN,PTEVT)=""
    155         S:$G(OR) ^ORE(100.2,"ASR",OR,PTEVT)=""
    156         K:EVT ^ORE(100.2,"AE",PAT,EVT,PTEVT)
    157         Q
    158         ;
    159 ALLDONE(DAD)    ; -- Returns 1 or 0, if all child events are done
    160         N I,Y S Y=1,I=0
    161         F  S I=+$O(^ORE(100.2,"DAD",+$G(DAD),I)) Q:I<1  I '$G(^ORE(100.2,I,1)) S Y=0 Q
    162         Q Y
    163         ;
    164 CHGEVT(IFN,NEWEVT)           ; -- Change the Patient Event for order IFN to NEWEVT
    165         ;    Includes adding or removing event pointer to order
    166         Q:'$G(IFN)  N PAT,OLDEVT,OR3 S:$G(NEWEVT) NEWEVT=+NEWEVT
    167         S PAT=$P($G(^OR(100,+IFN,0)),U,2),OLDEVT=$P($G(^(0)),U,17),OR3=$G(^(3))
    168         Q:OLDEVT=NEWEVT  K:OLDEVT ^OR(100,"AEVNT",PAT,OLDEVT,+IFN)
    169         S $P(^OR(100,+IFN,0),U,17)=NEWEVT S:NEWEVT ^OR(100,"AEVNT",PAT,NEWEVT,+IFN)=""
    170         I NEWEVT,$P(OR3,U,3)'=10 S $P(^OR(100,+IFN,3),U,3)=10,$P(^(8,1,0),U,15)=10
    171         I 'NEWEVT,$P(OR3,U,3)=10 S $P(^OR(100,+IFN,3),U,3)=11,$P(^(8,1,0),U,15)=11 D SET^ORDD100(+IFN,1)
    172         Q
    173         ;
    174 ACTLOG(PTEVT,ACTION,EVTYPE,SAVE)         ; -- Log a note for ACTION on PTEVT
    175         ;    SAVE => new data in VAIP() will be saved
    176         Q:'$G(PTEVT)  Q:'$D(^ORE(100.2,PTEVT,0))  Q:'$L($G(ACTION))
    177         N I,HDR,LAST,TOTAL,DA,ORNOW,MVT
    178         F I=1:1:10 L +^ORE(100.2,PTEVT,10,0):1 Q:$T  H 2
    179         Q:'$T "^" S HDR=$G(^ORE(100.2,PTEVT,10,0)) S:'$L(HDR) HDR="^100.25DA^^"
    180         S TOTAL=+$P(HDR,U,4),LAST=+$O(^ORE(100.2,PTEVT,10,"B"),-1)
    181         S I=LAST F I=(I+1):1 Q:'$D(^ORE(100.2,PTEVT,10,I,0))
    182         S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
    183         S ^ORE(100.2,PTEVT,10,0)=HDR L -^ORE(100.2,PTEVT,10,0)
    184         S ORNOW=+$$NOW^XLFDT,^ORE(100.2,PTEVT,10,"B",ORNOW,DA)=""
    185         S ^ORE(100.2,PTEVT,10,DA,0)=ORNOW_U_ACTION_U_$S(ACTION="LP":"",1:$G(DUZ))_U_$G(EVTYPE)
    186         S MVT=+$P($G(^ORE(100.2,PTEVT,1)),U,2)
    187         S:MVT ^ORE(100.2,"ADT",MVT,ORNOW,PTEVT,DA)=""
    188         I $G(SAVE),$G(VAIP(4)) S $P(^ORE(100.2,PTEVT,10,DA,0),U,5,7)=+VAIP(4)_U_+VAIP(8)_U_+VAIP(5)
    189         Q
    190         ;
    191 LAPSED(PTEVT)     ; -- Ck if PTEVT has lapsed, if so lapse all orders
    192         N Y,X0,EVT,ENTERED,DAYS S Y=0
    193         I $G(^ORE(100.2,PTEVT,1)) G LPQ ;already terminated
    194         S X0=$G(^ORE(100.2,PTEVT,0)),EVT=+$P(X0,U,2),ENTERED=+$P(X0,U,5)
    195         S:$P($G(^ORD(100.5,EVT,0)),U,12) EVT=+$P(^(0),U,12) ;parent
    196         S DAYS=+$P($G(^ORD(100.5,EVT,0)),U,6) I DAYS<1 G LPQ ;doesn't lapse
    197         I ENTERED>$$FMADD^XLFDT(DT,(0-DAYS)) G LPQ ;not lapsed yet
    198         D LP1(PTEVT) S Y=1 ;lapse orders, event
    199         N J S J=0 F  S J=$O(^ORE(100.2,"DAD",PTEVT,J)) Q:'J  D LP1(J)
    200 LPQ     Q Y
    201         ;
    202 LP1(PTEVT)      ; -- Lapse orders, event PTEVT
    203         N X0,PAT,IFN,STS
    204         S X0=$G(^ORE(100.2,PTEVT,0)),PAT=+$P(X0,U)_";DPT("
    205         S IFN=0 F  S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1  D
    206         . S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(STS=11)!(IFN=+$P(X0,U,4)) D
    207         .. D STATUS^ORCSAVE2(IFN,14)
    208         .. D ALPS^ORCSAVE2(IFN,1,"DELAYED ORDER")
    209         .. S $P(^OR(100,IFN,8,1,0),U,15)="" D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1)
    210         D DONE(PTEVT),ACTLOG(PTEVT,"LP")
    211         Q
     1OREVNTX ; SLC/MKB - Event delayed orders RPC's ; 08 May 2002  2:12 PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997
     3 ;
     4PAT(ORY,DFN)    ; -- Returns currently delayed events for patient DFN
     5 N EVT,CNT,X,Y S DFN=+$G(DFN),(EVT,CNT)=0
     6 F  S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1  S Y=+$O(^(EVT,0)) D
     7 . I $G(^ORE(100.2,Y,1)) K ^ORE(100.2,"AE",DFN,EVT,Y) Q
     8 . Q:$$LAPSED(Y)  ;I $$EMPTY(Y) D CANCEL(Y) Q
     9 . Q:$O(^ORE(100.2,"DAD",Y,0))  ;has children
     10 . S X=$P($G(^ORD(100.5,EVT,0)),U,8),X="Delayed "_$$LOWER^VALM1(X)
     11 . S CNT=CNT+1,ORY(CNT)=Y_U_X
     12 S:CNT ORY(0)=CNT
     13 Q
     14 ;
     15EXISTS(DFN,EVT) ; -- Returns 1 if patient DFN has delayed orders for EVT,
     16 ;    or 2 if parent/sibling event has delayed orders, else 0
     17 ;
     18 N X,Y,I S Y=0 I '$G(DFN)!'$G(EVT) G EXQ
     19 I $O(^ORE(100.2,"AE",+DFN,+EVT,0)) S Y=1 G EXQ
     20 S X=+$P($G(^ORD(100.5,+EVT,0)),U,12) I X D  G EXQ ;ck parent,siblings
     21 . I $O(^ORE(100.2,"AE",+DFN,X,0)) S Y=2 Q
     22 . S I=0 F  S I=+$O(^ORD(100.5,"DAD",X,I)) Q:I<1  I $O(^ORE(100.2,"AE",+DFN,I,0)) S Y=2 Q
     23EXQ Q Y
     24 ;
     25LIST(ORY,DFN)   ; -- Returns all processed events for patient DFN as
     26 ;    ORY(#) = PatEvtIEN ^ Display Text ^ EvtDateTime
     27 ;             in reverse chronological order
     28 N IDT,DA,CNT,X0,X1,EVT,DC,X
     29 S DFN=+$G(DFN),(IDT,CNT)=0
     30 F  S IDT=$O(^ORE(100.2,"AC",DFN,IDT)) Q:IDT<1  D
     31 . S DA=0 F  S DA=+$O(^ORE(100.2,"AC",DFN,IDT,DA)) Q:DA<1  D
     32 .. S X0=$G(^ORE(100.2,DA,0)),X1=$G(^(1)) Q:$P(X1,U,5)  ;has parent
     33 .. S EVT=+$P(X0,U,2),DC=+$P(X1,U,3)
     34 .. I '$P(X0,U,4),'$O(^ORE(100.2,DA,2,0)),'$O(^ORE(100.2,DA,3,0)),'$D(^OR(100,"AEVNT",DFN_";DPT(",DA)) Q  ;no orders
     35 .. S I=+$O(^ORE(100.2,DA,10,"B"),-1),X=$P($G(^(I,0)),U,2) I X="LP"!(X="CA") Q  ;lapsed or cancelled
     36 .. ;Q if not current admission?
     37 .. S X=$S(EVT:$P($G(^ORD(100.5,EVT,0)),U,8),DC:$P($G(^ORD(100.6,DC,0)),U,5),1:"UNSPECIFIED EVENT")
     38 .. S X=$$LOWER^VALM1(X),CNT=CNT+1,ORY(CNT)=DA_U_X_U_$P(X1,U)
     39 S:CNT ORY(0)=CNT
     40 Q
     41 ;
     42COMP(PTEVT) ; -- Returns 1 or 0, if PTEVT has been completed
     43 N Y,I S Y=$S($G(^ORE(100.2,+$G(PTEVT),1)):1,1:0)
     44 I Y S I=+$O(^ORE(100.2,+$G(PTEVT),10,0)) S:$P($G(^(I,0)),U,2)="CA" Y=0
     45 Q Y
     46 ;
     47ACTIVE(ORY,TYPE)     ; -- Returns all active events [of TYPE] from #100.5
     48 ;  where TYPE=string containing any of the codes from the TYPE field
     49 N NM,IEN,CNT,X0,X S CNT=0,TYPE=$G(TYPE)
     50 S NM="" F  S NM=$O(^ORD(100.5,"C",NM)) Q:NM=""  D
     51 . S IEN=0 F  S IEN=+$O(^ORD(100.5,"C",NM,IEN)) Q:IEN<1  D
     52 .. S X0=$G(^ORD(100.5,IEN,0)) I '$L($P(X0,U,2)) D  ;Child event
     53 ... S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2)
     54 .. I $L(TYPE),TYPE'[$P(X0,U,2) Q
     55 .. Q:$O(^ORD(100.5,"DAD",IEN,0))  ;Parent event
     56 .. S CNT=CNT+1,ORY(CNT)=IEN_U_X0
     57 S:CNT ORY(0)=CNT
     58 Q
     59 ;
     60NAME(PTEVT)     ; -- Return name of Patient Event
     61 N X,Y,Z S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2),Z=$G(^(1))
     62 S:X Y=$P($G(^ORD(100.5,X,0)),U,8)
     63 I 'X S X=+$P(Z,U,3),Y=$P($G(^ORD(100.6,X,0)),U,5)
     64 S Y=$S('Z:"Delayed ",1:"")_$$LOWER^VALM1(Y)
     65 Q Y
     66 ;
     67SHORTNM(PTEVT)  ; -- Return Short Name of Patient Event
     68 ;   or first 15 characters of Event Name if unspecified
     69 N X,Y,Y0 S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) I X D
     70 . S Y0=$G(^ORD(100.5,X,0)),Y=$P(Y0,U,10)
     71 . S:'$L(Y) Y=$E($P(Y0,U,8),1,15)
     72 I 'X S X=+$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3),Y=$E($P($G(^ORD(100.6,X,0)),U,5),1,15)
     73 Q Y
     74 ;
     75EVT(PTEVT)      ; -- Return Event ptr #100.5, given PTEVT ptr #100.2
     76 Q +$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
     77 ;
     78DC(PTEVT) ; -- Return DC Rule ptr #100.6, given PTEVT ptr #100.2
     79 I $P($G(^ORE(100.2,+$G(PTEVT),1)),U,5) S PTEVT=$P(^(1),U,5) ;use parent
     80 Q +$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3)
     81 ;
     82TYPE(PTEVT)     ; -- Return Type of Patient Event (i.e. A/D/T)
     83 N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
     84 I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent
     85 S Y=$S(X:$P($G(^ORD(100.5,X,0)),U,2),1:"DC")
     86 Q Y
     87 ;
     88DIV(PTEVT)      ; -- Return Division for PTEVT
     89 N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
     90 I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent
     91 S Y=+$P($G(^ORD(100.5,X,0)),U,3) S:Y<1 Y=+$G(DUZ(2))
     92 Q Y
     93 ;
     94LOC(PTEVT)      ; -- Return Default Ordering Location for PTEVT
     95 N X,X0,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2)
     96 S X0=$G(^ORD(100.5,X,0)),Y=+$P(X0,U,9)_";SC("
     97 I Y<1,$P(X0,U,12) S Y=+$P($G(^ORD(100.5,+$P(X0,U,12),0)),U,9)_";SC("
     98 S:Y<1 Y=$G(ORL)
     99 Q Y
     100 ;
     101EMPTY(PTEVT)    ; -- Returns 1 or 0, if PTEVT has delayed orders
     102 N Y,OR0,PAT,TYPE,PSO,IFN,STS S Y=1 I '$G(PTEVT) Q Y
     103 S OR0=$G(^ORE(100.2,+PTEVT,0)),PAT=+$P(OR0,U)_";DPT("
     104 S TYPE=$$TYPE(PTEVT) I TYPE="D" S PSO=+$O(^DIC(9.4,"C","PSO",0))
     105 S IFN=0 F  S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1  D  Q:'Y
     106 . S STS=$P($G(^OR(100,IFN,3)),U,3) I STS=10 S Y=0 Q
     107 . ;I IFN=+$P(OR0,U,4),STS=11!(STS=6) S Y=0 Q
     108 . I TYPE="D",$P($G(^OR(100,IFN,0)),U,14)=PSO,STS=5!(STS=6) S Y=0 Q
     109 I Y,$D(^ORE(100.2,"DAD",PTEVT)) D  ;ck child events
     110 . N CHLD S CHLD=0
     111 . F  S CHLD=+$O(^ORE(100.2,"DAD",PTEVT,CHLD)) Q:CHLD<1  D  Q:'Y
     112 .. S IFN=0 F  S IFN=$O(^OR(100,"AEVNT",PAT,CHLD,IFN)) Q:IFN<1  I $P($G(^OR(100,IFN,3)),U,3)=10 S Y=0 Q
     113 Q Y
     114 ;
     115EVTORDER(ORDER) ; -- Returns 1 or 0, if ORDER is for event
     116 ;    Will return 0 if action DA is included but not NW
     117 N X0,X,Y S X0=$G(^OR(100,+ORDER,0)),X=+$P(ORDER,";",2),Y=0
     118 I $P(X0,U,17),X'>1 D
     119 . I $P($G(^ORE(100.2,+$P(X0,U,17),0)),U,4)=+ORDER S Y=1 Q
     120 . S DAD=+$P($G(^ORE(100.2,+$P(X0,U,17),1)),U,5) ;has parent?
     121 . I DAD,$P($G(^ORE(100.2,DAD,0)),U,4)=+ORDER S Y=1
     122 Q Y
     123 ;
     124MANREL(ORDER)   ; -- Returns 1 or 0, if ORDER was manually released
     125 N EVT,Y,RELDT,TYPE,EVTDT S Y=0
     126 S EVT=+$P($G(^OR(100,+ORDER,0)),U,17),RELDT=+$P($G(^(8,1,0)),U,16)
     127 G:EVT<1 MNQ G:RELDT<1 MNQ ;not delayed or released
     128 I '$D(^ORE(100.2,EVT,2,+ORDER)) S Y=1 G MNQ ;not rel'd by event
     129 S TYPE=$$TYPE(EVT),EVTDT=+$G(^ORE(100.2,EVT,1))
     130 I TYPE="M",$$FMDIFF^XLFDT(EVTDT,RELDT,2)<300 S Y=1
     131MNQ Q Y
     132 ;
     133CANCEL(PTEVT)   ; -- Cancel empty PTEVT, event order
     134 S PTEVT=+$G(PTEVT) D DONE(PTEVT),ACTLOG(PTEVT,"CA")
     135 N IFN,DAD S IFN=+$P($G(^ORE(100.2,PTEVT,0)),U,4)
     136 I IFN<1 D  ;ck for parent w/event order
     137 . S DAD=+$P($G(^ORE(100.2,PTEVT,1)),U,5) Q:DAD<1
     138 . Q:'$G(^ORE(100.2,DAD,1))  ;parent still active
     139 . S IFN=+$P($G(^ORE(100.2,DAD,0)),U,4)
     140 I IFN D:'$$DCD^ORCACT2(IFN) CLRDLY^ORCACT2(IFN) ;cancel event order
     141 Q
     142 ;
     143DONE(PTEVT,WHEN,MVT,OR)    ; -- Terminate PTEVT
     144 Q:'$G(PTEVT)  Q:'$D(^ORE(100.2,PTEVT,0))
     145 N X0,X1,PAT,EVT,DAD
     146 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) D D1
     147 S DAD=$P(X1,U,5) I DAD,$$ALLDONE(DAD) S PTEVT=DAD D D1 Q
     148 S DAD=PTEVT,PTEVT=0 ;if PTEVT=parent, terminate children too
     149 F  S PTEVT=+$O(^ORE(100.2,"DAD",DAD,PTEVT)) Q:PTEVT<1  D D1
     150 Q
     151D1 S X0=$G(^ORE(100.2,+PTEVT,0)),X1=$G(^(1)) Q:'$L(X0)
     152 S PAT=+$P(X0,U),EVT=+$P(X0,U,2) ;,ORD=+$P(X0,U,4)
     153 S $P(X1,U,1,2)=WHEN_U_$G(MVT),$P(X1,U,4)=$G(OR),^ORE(100.2,PTEVT,1)=X1
     154 S ^ORE(100.2,"AC",PAT,9999999-WHEN,PTEVT)=""
     155 S:$G(OR) ^ORE(100.2,"ASR",OR,PTEVT)=""
     156 K:EVT ^ORE(100.2,"AE",PAT,EVT,PTEVT)
     157 Q
     158 ;
     159ALLDONE(DAD) ; -- Returns 1 or 0, if all child events are done
     160 N I,Y S Y=1,I=0
     161 F  S I=+$O(^ORE(100.2,"DAD",+$G(DAD),I)) Q:I<1  I '$G(^ORE(100.2,I,1)) S Y=0 Q
     162 Q Y
     163 ;
     164CHGEVT(IFN,NEWEVT)      ; -- Change the Patient Event for order IFN to NEWEVT
     165 ;    Includes adding or removing event pointer to order
     166 Q:'$G(IFN)  N PAT,OLDEVT,OR3 S:$G(NEWEVT) NEWEVT=+NEWEVT
     167 S PAT=$P($G(^OR(100,+IFN,0)),U,2),OLDEVT=$P($G(^(0)),U,17),OR3=$G(^(3))
     168 Q:OLDEVT=NEWEVT  K:OLDEVT ^OR(100,"AEVNT",PAT,OLDEVT,+IFN)
     169 S $P(^OR(100,+IFN,0),U,17)=NEWEVT S:NEWEVT ^OR(100,"AEVNT",PAT,NEWEVT,+IFN)=""
     170 I NEWEVT,$P(OR3,U,3)'=10 S $P(^OR(100,+IFN,3),U,3)=10,$P(^(8,1,0),U,15)=10
     171 I 'NEWEVT,$P(OR3,U,3)=10 S $P(^OR(100,+IFN,3),U,3)=11,$P(^(8,1,0),U,15)=11 D SET^ORDD100(+IFN,1)
     172 Q
     173 ;
     174ACTLOG(PTEVT,ACTION,EVTYPE,SAVE)  ; -- Log a note for ACTION on PTEVT
     175 ;    SAVE => new data in VAIP() will be saved
     176 Q:'$G(PTEVT)  Q:'$D(^ORE(100.2,PTEVT,0))  Q:'$L($G(ACTION))
     177 N I,HDR,LAST,TOTAL,DA,ORNOW,MVT
     178 F I=1:1:10 L +^ORE(100.2,PTEVT,10,0):1 Q:$T  H 2
     179 Q:'$T "^" S HDR=$G(^ORE(100.2,PTEVT,10,0)) S:'$L(HDR) HDR="^100.25DA^^"
     180 S TOTAL=+$P(HDR,U,4),LAST=+$O(^ORE(100.2,PTEVT,10,"B"),-1)
     181 S I=LAST F I=(I+1):1 Q:'$D(^ORE(100.2,PTEVT,10,I,0))
     182 S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
     183 S ^ORE(100.2,PTEVT,10,0)=HDR L -^ORE(100.2,PTEVT,10,0)
     184 S ORNOW=+$$NOW^XLFDT,^ORE(100.2,PTEVT,10,"B",ORNOW,DA)=""
     185 S ^ORE(100.2,PTEVT,10,DA,0)=ORNOW_U_ACTION_U_$S(ACTION="LP":"",1:$G(DUZ))_U_$G(EVTYPE)
     186 S MVT=+$P($G(^ORE(100.2,PTEVT,1)),U,2)
     187 S:MVT ^ORE(100.2,"ADT",MVT,ORNOW,PTEVT,DA)=""
     188 I $G(SAVE),$G(VAIP(4)) S $P(^ORE(100.2,PTEVT,10,DA,0),U,5,7)=+VAIP(4)_U_+VAIP(8)_U_+VAIP(5)
     189 Q
     190 ;
     191LAPSED(PTEVT)   ; -- Ck if PTEVT has lapsed, if so lapse all orders
     192 N Y,X0,EVT,ENTERED,DAYS S Y=0
     193 I $G(^ORE(100.2,PTEVT,1)) G LPQ ;already terminated
     194 S X0=$G(^ORE(100.2,PTEVT,0)),EVT=+$P(X0,U,2),ENTERED=+$P(X0,U,5)
     195 S:$P($G(^ORD(100.5,EVT,0)),U,12) EVT=+$P(^(0),U,12) ;parent
     196 S DAYS=+$P($G(^ORD(100.5,EVT,0)),U,6) I DAYS<1 G LPQ ;doesn't lapse
     197 I ENTERED>$$FMADD^XLFDT(DT,(0-DAYS)) G LPQ ;not lapsed yet
     198 D LP1(PTEVT) S Y=1 ;lapse orders, event
     199LPQ Q Y
     200 ;
     201LP1(PTEVT) ; -- Lapse orders, event PTEVT
     202 N X0,PAT,IFN,STS
     203 S X0=$G(^ORE(100.2,PTEVT,0)),PAT=+$P(X0,U)_";DPT("
     204 S IFN=0 F  S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1  D
     205 . S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(STS=11)!(IFN=+$P(X0,U,4)) D
     206 .. D STATUS^ORCSAVE2(IFN,14)
     207 .. S $P(^OR(100,IFN,8,1,0),U,15)="" D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1)
     208 D DONE(PTEVT),ACTLOG(PTEVT,"LP")
     209 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX1.m

    r613 r623  
    1 OREVNTX1        ; SLC/JLI - Event delayed orders RPC's ;9/19/02  13:35
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,149,243**;Dec 17, 1997;Build 242
    3         ;
    4 PUTEVNT(ORY,DFN,EVT,ORIFN)      ; Save new patient delayed events to file 100.2
    5         S ORY=$$NEW^OREVNT(DFN,EVT,ORIFN)
    6         Q
    7         ;
    8 GTEVT(ORY,PTEVT)        ; Return Event infomation based on PTEVT ptr #100.2
    9         ;EVTID     ptr #100.5
    10         Q:'+PTEVT
    11         N EVTID,EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT
    12         S (EVTTYPE,EVTNAME,EVTDISP,PRTEVT)=""
    13         S EVTDLG=0
    14         I '$P(^ORE(100.2,+$G(PTEVT),0),U,2) Q
    15         S EVTID=$$EVT^OREVNTX(PTEVT)
    16         S PRTEVT=$P(^ORD(100.5,EVTID,0),U,12)
    17         I PRTEVT S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2)
    18         E  S EVTTYPE=$P(^ORD(100.5,EVTID,0),U,2)
    19         I $D(^ORD(100.5,EVTID,0)) D
    20         . S EVTNAME=$P(^ORD(100.5,EVTID,0),U,1)
    21         . S EVTDISP=$P(^ORD(100.5,EVTID,0),U,8)
    22         . S EVTDLG=$P(^ORD(100.5,EVTID,0),U,4)
    23         S ORY=EVTTYPE_U_EVTID_U_EVTNAME_U_EVTDISP_U_EVTDLG
    24         Q
    25 GTEVT1(ORY,EVT) ; Return Event information based on EVT ptr #100.5
    26         ;EVT    ptr #100.5
    27         Q:'+EVT
    28         N EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT
    29         S (EVTDLG,PRTEVT)=0
    30         S PRTEVT=$P(^ORD(100.5,+EVT,0),U,12)
    31         I PRTEVT>0 S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2)
    32         E  S EVTTYPE=$P(^ORD(100.5,+EVT,0),U,2)
    33         S EVTNAME=$P($G(^ORD(100.5,+EVT,0)),U,1)
    34         S EVTDISP=$P($G(^ORD(100.5,+EVT,0)),U,8)
    35         S EVTDLG=$P($G(^ORD(100.5,+EVT,0)),U,4)
    36         S ORY=EVTTYPE_U_EVT_U_EVTNAME_U_EVTDISP_U_EVTDLG
    37         Q
    38         ;
    39 EVT(ORY,PTEVT)  ; Return Event ptr #100.5, given PTEVT ptr #100.2
    40         Q:'+PTEVT
    41         S ORY=$$EVT^OREVNTX(PTEVT)
    42         Q
    43         ;
    44 EXISTS(ORY,DFN,EVT)     ;Returns PtEvtID ptr #100.2 if patient already has delayed orders
    45         I '+EVT S ORY=0 Q
    46         N PTEVT S (PTEVT,ORY)=0
    47         S PTEVT=$O(^ORE(100.2,"AE",+DFN,+EVT,PTEVT))
    48         I PTEVT>0 S ORY=PTEVT
    49         Q
    50         ;
    51 TYPEXT(ORY,DFN,EVT)     ; does EVT has delayed orders?
    52         ; 1 if Patient DFN has delayed orders for EVT
    53         ; 2 if Parent/Sibling event has delayed orders
    54         ; 0 if No delayed orders for EVT
    55         Q:'+EVT
    56         S ORY=$$EXISTS^OREVNTX(DFN,EVT)
    57         Q
    58         ;
    59 MATCH(ORY,DFN,EVT)      ;If Pt's current data match selected event
    60         ;DFN: patient DFN
    61         ;EVT: ptr to #100.5
    62         S ORY=0
    63         Q:('+DFN)!('+EVT)
    64         S ORY=$$MATCH^OREVNT(DFN,EVT)
    65         N TS,TSNM
    66         S TS=$S($G(ORTS):+ORTS,1:+$G(^DPT(DFN,.103)))
    67         S TSNM=$P($G(^DIC(45.7,TS,0)),U)
    68         S:ORY ORY=ORY_U_TSNM
    69         Q
    70         ;
    71 NAME(ORY,PTEVT) ; Return Event name from #100.5, given PTEVT ptr #100.2
    72         I PTEVT'>0 S ORY="" Q
    73         S ORY=$$NAME^OREVNTX(PTEVT)
    74         Q
    75         ;
    76 DIV(ORY,PTEVT)  ; Return division for PTEVT ptr #100.2
    77         Q:'+PTEVT
    78         S ORY=$$DIV^OREVNTX(PTEVT)
    79         Q
    80         ;
    81 DIV1(ORY,EVT)   ; Return division for EVT ptr #100.5
    82         Q:'+EVT
    83         S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,3) S:ORY<1 ORY=+$G(DUZ(2))
    84         Q
    85         ;
    86 LOC(ORY,PTEVT)  ; Return default hospital location ^SC( for PTEVT ptr #100.2
    87         Q:'+PTEVT
    88         S ORY=$$LOC^OREVNTX(PTEVT)
    89         S ORY=+ORY
    90         Q
    91         ;
    92 LOC1(ORY,EVT)   ; Return default hospital location ^SC( for EVT ptr #100.5
    93         Q:'+EVT
    94         S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,9) S:ORY<1 ORY=+$G(ORL)
    95         Q
    96         ;
    97 CHGEVT(ORY,NEWEVT,ORIDS)        ; Change order's event
    98         N ORI
    99         S ORI=0
    100         F  S ORI=$O(ORIDS(ORI)) Q:'+ORI  D
    101         . D CHGEVT^OREVNTX(+$G(ORIDS(ORI)),NEWEVT)
    102         Q
    103         ;
    104 EMPTY(ORY,PTEVT)        ; Return 1 if PTEVT doesn't have any orders
    105         Q:'+PTEVT
    106         S ORY=$$EMPTY^OREVNTX(PTEVT)
    107         Q
    108         ;
    109 DELPTEVT(ORY,PTEVT)     ; Delete Patient Event in #100.2
    110         Q:'+PTEVT
    111         D CANCEL^OREVNTX(PTEVT)
    112         Q
    113         ;
    114 UPDTOR(ORY,PTIFN,ORIFN,PTEVT)   ; If delayed order was DCed, then update the EVENT and "AEVNT"
    115         Q  ;Don't ever need to do this!
    116 CURSPE(ORY,PTIFN)       ; Return current treating specialty
    117         Q:'PTIFN
    118         N SPEC S SPEC=$$PT^DGPMOBS(PTIFN),ORY=""
    119         I SPEC'<0 S ORY=$P(SPEC,U,3)_U_$P(SPEC,U,2)_U_$P(SPEC,U) ;name^ien^obs flag
    120         Q
    121 DFLTEVT(ORY,PVIFN)      ; Return default release event based on provider IFN
    122         N CMEVTLST,IDX
    123         S CMEVTLST="",IDX=0
    124         D GETLST^OREV3(.CMEVTLST)
    125         F  S IDX=$O(CMEVTLST(IDX)) Q:'IDX  D
    126         . I $P($G(CMEVTLST(IDX)),U,2) S ORY=$P($G(CMEVTLST(IDX)),U) Q
    127         Q
    128 CMEVTS(ORY,CLOC)        ;Return common event list
    129         N IDX,X0,X,LOC
    130         S:CLOC>0 LOC=CLOC
    131         S IDX=0,ORY=""
    132         D GETLST^OREV3(.ORY)
    133         F  S IDX=$O(ORY(IDX)) Q:'IDX  D
    134         . S X0=""
    135         . S:$L($G(^ORD(100.5,+ORY(IDX),0))) X0=$G(^(0))
    136         . I '$L($P(X0,U,2)) D
    137         .. S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2)
    138         . S:$L(X0) ORY(IDX)=+ORY(IDX)_U_X0
    139         Q
    140         ;
    141 DELDFLT(ORY,PVIFN)      ; Delete default release event
    142         Q:'PVIFN
    143         N ORERR
    144         S ORERR=""
    145         D DEL^XPAR(PVIFN_";VA(200,","OREVNT DEFAULT",1,.ORERR)
    146         Q
    147 WRLSTED(LST,LOC,EVTID)  ; Return list of dialogs for writing event delayed orders
    148         ; .Y(n): DlgName^ListBox Text
    149 WRLST1  N ANENT
    150         S LOC=+$G(LOC)_";SC(" I 'LOC S LOC=""
    151         S ANENT="ALL^USR.`"_DUZ_"^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
    152         N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP
    153         S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS EVENT LIST",EVTID,"I") Q:'MNU
    154         S SEQ=0 F  S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ  D
    155         . S IEN=0 F  S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN  D
    156         . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4)
    157         . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5)
    158         . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5)
    159         . . S:'$L(TXT) TXT=$P(X,U,2)
    160         . . I TYP="M" S:'FID FID=1001
    161         . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT
    162         Q
    163         ;
    164 GETDLG(LST,DLGID)       ; Return dialog infomation based on the DLGID
    165         N DIEN,DFID,DTXT,DTYP,DGRP,X0,X5
    166         S DLGID=+DLGID
    167         Q:'DLGID
    168         S X0=^ORD(101.41,DLGID,0),X5=$G(^(5))
    169         S DGRP=+$P(X0,U,5),DFID=+$P(X5,U,5),DTXT=$P(X5,U,4),DTYP=$P(X0,U,4)
    170            S:'$L(DTXT) DTXT=$P(X0,U,2)
    171         I $P(X0,U,4)="M" S:'DFID DFID=1001
    172         S LST=DLGID_";"_DFID_";"_DGRP_";"_DTYP_U_DTXT
    173         Q
    174 DONE(LST,PTEVT) ; Terminate PTEvt
    175         Q:'PTEVT
    176         D DONE^OREVNTX(PTEVT)
    177         D ACTLOG^OREVNTX(PTEVT,"MN")
    178         Q
    179 SETDFLT(ORY,EVT)        ;Set personal default event
    180         N ERR,VAL S ERR=""
    181         Q:'$D(^ORD(100.5,EVT,0))
    182         S VAL=$P(^ORD(100.5,EVT,0),U)
    183         D EN^XPAR(DUZ_";VA(200,","OREVNT DEFAULT",1,VAL,ERR)
    184         S ORY=ERR
    185         Q
    186 CPACT(ORY,EVT)  ; Return True/False to display active orders for copy
    187         ; EVT ptr to #100.5
    188         Q:'EVT
    189         S ORY=0
    190         Q:'$D(^ORD(100.5,EVT,0))
    191         S ORY=$P(^ORD(100.5,EVT,0),U,11)
    192         Q
    193 PRMPTID(ORY,PRTNM)      ;Return event prompt IEN for OR GTX EVENT
    194         S:$D(^ORD(101.41,"B","OR GTX EVENT")) ORY=$O(^("OR GTX EVENT",0))
    195         Q
    196 ISDCOD(ORY,ORIFN)       ;True: the order need to be filtered out
    197         N PAS,X3,X0,ORGRPLST,THEGRP,IDX,ODGRP
    198         S (ORY,IDX)=0
    199         Q:'$D(^OR(100,+ORIFN,0))
    200         S X0=$G(^OR(100,+ORIFN,0))
    201         S ODGRP=$P(X0,U,11)
    202         D GETLST^XPAR(.ORGRPLST,"ALL","OREVNT EXCLUDE DGRP")
    203         F  S IDX=$O(ORGRPLST(IDX)) Q:'IDX!ORY  D
    204         . S THEGRP=$P($G(ORGRPLST(IDX)),U,2)
    205         . I $$GRPCHK(THEGRP,ODGRP) S ORY=1
    206         I ORY Q
    207         S PAS=";1;"
    208         S:$D(^OR(100,+ORIFN,3)) X3=^OR(100,+ORIFN,3)
    209         S:(PAS'[(";"_$P(X3,U,3)_";")) ORY=0
    210         Q
    211 DEFLTS(ORY,EVTID)       ;Return default specialty for EVTID(#100.5)
    212         Q:'+EVTID
    213         N PRTEVT
    214         S PRTEVT=0
    215         S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12)
    216         I PRTEVT>0 S EVTID=PRTEVT
    217         S ORY=$$DEFTS^ORCDADT(EVTID)
    218         Q
    219         ;
    220 MULTS(ORY,EVTID)        ;Return specialty list for the EVTID(#100.5)
    221         Q:'+EVTID
    222         N I,CNT,X,Y S (I,CNT)=0
    223         N PRTEVT
    224         S PRTEVT=0
    225         S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12)
    226         I PRTEVT>0 S EVTID=PRTEVT
    227         F  S I=$O(^ORD(100.5,+$G(EVTID),"TS",I)) Q:I<1  S X=+$G(^(I,0)) D
    228         . S Y=$$GET1^DIQ(45.7,X_",",.01)
    229         . S CNT=CNT+1,ORY(CNT)=X_U_Y
    230         Q
    231         ;
    232 PRTIDS(ORY,IDS) ;Return some prompt ids from #101.41
    233         ; treating specialty Id^attending provider id
    234         N IDX,ORTS,ORATT
    235         S (ORY,ORTS,ORATT)=""
    236         S IDX=$O(^ORD(101.41,"B","OR GTX TREATING SPECIALTY",0))
    237         S:$D(^ORD(101.41,IDX,1)) ORTS=$P($G(^ORD(101.41,IDX,1)),U,2,3)
    238         S IDX=$O(^ORD(101.41,"B","OR GTX PROVIDER",0))
    239         S:$D(^ORD(101.41,IDX,1)) ORATT=$P($G(^ORD(101.41,IDX,1)),U,2,3)
    240         S ORY=ORTS_"~"_ORATT
    241         Q
    242         ;
    243 DFLTDLG(ORY,EVTID)      ;Return event default dialog IEN
    244         S ORY=0
    245         Q:'$D(^ORD(100.5,+EVTID,0))
    246         S ORY=$P(^ORD(100.5,+EVTID,0),U,4)
    247         Q
    248 AUTHMREL(ORY,USER)      ;1: user can manual release delayed orders 0: can't
    249         S ORY=$$CANREL^OREV3
    250         Q
    251 HAVEPRT(ORY,PTEVT)      ;return parent patient event from #100.2
    252         Q:'+PTEVT
    253         S ORY=""
    254         S:$L($G(^ORE(100.2,PTEVT,1))) ORY=$P(^(1),U,5)
    255         Q
    256 GRPCHK(DG,AGRP) ;If an order's group belong to DG group
    257         N RST
    258         S RST=0
    259         N ORGRP
    260         D GRP^ORQ1(DG)
    261         S RST=$S($D(ORGRP(AGRP)):1,1:0)
    262         Q RST
    263 ODPTEVID(ORY,ORID)      ;Return PtEvtID based on the ORID
    264         Q:'$D(^OR(100,+ORID,0))
    265         S ORY=$P($G(^OR(100,+ORID,0)),U,17)
    266         Q
    267 COMP(ORY,PTEVT) ;Return 1 or 0 if PTEVT completed or not
    268         Q:'+PTEVT
    269         S ORY=$$COMP^OREVNTX(+PTEVT)
    270         Q
    271 ISHDORD(ORY,ORID)       ;Return 1 if it's on-hold med order
    272         Q:'+ORID
    273         Q:'$D(^OR(100,+ORID,0))
    274         N STS,HDSTS,ODGP,INPT,OUPT,MEDS,IVMD
    275         S HDSTS=$O(^ORD(100.01,"B","HOLD",0))
    276         S STS=$P($G(^OR(100,+ORID,3)),U,3)
    277         S INPT=$O(^ORD(100.98,"B","UD RX",0))
    278         S OUPT=$O(^ORD(100.98,"B","O RX",0))
    279         S MEDS=$O(^ORD(100.98,"B","RX",0))
    280         S IVMD=$O(^ORD(100.98,"B","IV RX",0))
    281         S ODGP=$P(^OR(100,+ORID,0),U,11)
    282         I (U_INPT_U_OUPT_U_MEDS_U_IVMD_U[U_ODGP_U),(HDSTS=STS) S ORY=1
    283         Q
    284 ISPASS(ORY,PTEVTID,EVTTYPE)     ;Return 1 if it's a pass event
    285         S ORY=$$EVT^OREVNTX(PTEVTID)
    286         S ORY=$P($G(^ORD(100.5,+ORY,0)),U,7)
    287         I EVTTYPE="T",ORY,ORY<4 S ORY=1
    288         E  S ORY=0
    289         Q
    290 ISPASS1(ORY,EVTID,EVTTYPE)      ;Return 1 if it's a pass event
    291         S ORY=$P($G(^ORD(100.5,+EVTID,0)),U,7)
    292         I EVTTYPE="T",ORY,ORY<4 S ORY=1
    293         E  S ORY=0
    294         Q
    295 DLGIEN(ORY,DLGNAME)     ;Return Order Dialog IEN based on name
    296         Q:'$D(^ORD(101.41,"B",DLGNAME))
    297         S ORY=$O(^ORD(101.41,"B",DLGNAME,0))
    298         Q
    299 GETSTS(ORY,ORDID)       ;Return Order status
    300         Q:'+ORDID
    301         Q:'$D(^OR(100,+ORDID,0))
    302         S ORY=$P($G(^OR(100,+ORDID,3)),U,3)
    303         Q
     1OREVNTX1 ; SLC/JLI - Event delayed orders RPC's ;9/19/02  13:35
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,149**;Dec 17, 1997
     3 ;
     4PUTEVNT(ORY,DFN,EVT,ORIFN) ; Save new patient delayed events to file 100.2
     5 S ORY=$$NEW^OREVNT(DFN,EVT,ORIFN)
     6 Q
     7 ;
     8GTEVT(ORY,PTEVT) ; Return Event infomation based on PTEVT ptr #100.2
     9 ;EVTID     ptr #100.5
     10 Q:'+PTEVT
     11 N EVTID,EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT
     12 S (EVTTYPE,EVTNAME,EVTDISP,PRTEVT)=""
     13 S EVTDLG=0
     14 I '$P(^ORE(100.2,+$G(PTEVT),0),U,2) Q
     15 S EVTID=$$EVT^OREVNTX(PTEVT)
     16 S PRTEVT=$P(^ORD(100.5,EVTID,0),U,12)
     17 I PRTEVT S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2)
     18 E  S EVTTYPE=$P(^ORD(100.5,EVTID,0),U,2)
     19 I $D(^ORD(100.5,EVTID,0)) D
     20 . S EVTNAME=$P(^ORD(100.5,EVTID,0),U,1)
     21 . S EVTDISP=$P(^ORD(100.5,EVTID,0),U,8)
     22 . S EVTDLG=$P(^ORD(100.5,EVTID,0),U,4)
     23 S ORY=EVTTYPE_U_EVTID_U_EVTNAME_U_EVTDISP_U_EVTDLG
     24 Q
     25GTEVT1(ORY,EVT) ; Return Event information based on EVT ptr #100.5
     26 ;EVT    ptr #100.5
     27 Q:'+EVT
     28 N EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT
     29 S (EVTDLG,PRTEVT)=0
     30 S PRTEVT=$P(^ORD(100.5,+EVT,0),U,12)
     31 I PRTEVT>0 S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2)
     32 E  S EVTTYPE=$P(^ORD(100.5,+EVT,0),U,2)
     33 S EVTNAME=$P($G(^ORD(100.5,+EVT,0)),U,1)
     34 S EVTDISP=$P($G(^ORD(100.5,+EVT,0)),U,8)
     35 S EVTDLG=$P($G(^ORD(100.5,+EVT,0)),U,4)
     36 S ORY=EVTTYPE_U_EVT_U_EVTNAME_U_EVTDISP_U_EVTDLG
     37 Q
     38 ;
     39EVT(ORY,PTEVT) ; Return Event ptr #100.5, given PTEVT ptr #100.2
     40 Q:'+PTEVT
     41 S ORY=$$EVT^OREVNTX(PTEVT)
     42 Q
     43 ;
     44EXISTS(ORY,DFN,EVT) ;Returns PtEvtID ptr #100.2 if patient already has delayed orders
     45 I '+EVT S ORY=0 Q
     46 N PTEVT S (PTEVT,ORY)=0
     47 S PTEVT=$O(^ORE(100.2,"AE",+DFN,+EVT,PTEVT))
     48 I PTEVT>0 S ORY=PTEVT
     49 Q
     50 ;
     51TYPEXT(ORY,DFN,EVT) ; does EVT has delayed orders?
     52 ; 1 if Patient DFN has delayed orders for EVT
     53 ; 2 if Parent/Sibling event has delayed orders
     54 ; 0 if No delayed orders for EVT
     55 Q:'+EVT
     56 S ORY=$$EXISTS^OREVNTX(DFN,EVT)
     57 Q
     58 ;
     59MATCH(ORY,DFN,EVT) ;If Pt's current data match selected event
     60 ;DFN: patient DFN
     61 ;EVT: ptr to #100.5
     62 S ORY=0
     63 Q:('+DFN)!('+EVT)
     64 S ORY=$$MATCH^OREVNT(DFN,EVT)
     65 N TS,TSNM
     66 S TS=$S($G(ORTS):+ORTS,1:+$G(^DPT(DFN,.103)))
     67 S TSNM=$P($G(^DIC(45.7,TS,0)),U)
     68 S:ORY ORY=ORY_U_TSNM
     69 Q
     70 ;
     71NAME(ORY,PTEVT) ; Return Event name from #100.5, given PTEVT ptr #100.2
     72 I PTEVT'>0 S ORY="" Q
     73 S ORY=$$NAME^OREVNTX(PTEVT)
     74 Q
     75 ;
     76DIV(ORY,PTEVT) ; Return division for PTEVT ptr #100.2
     77 Q:'+PTEVT
     78 S ORY=$$DIV^OREVNTX(PTEVT)
     79 Q
     80 ;
     81DIV1(ORY,EVT) ; Return division for EVT ptr #100.5
     82 Q:'+EVT
     83 S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,3) S:ORY<1 ORY=+$G(DUZ(2))
     84 Q
     85 ;
     86LOC(ORY,PTEVT) ; Return default hospital location ^SC( for PTEVT ptr #100.2
     87 Q:'+PTEVT
     88 S ORY=$$LOC^OREVNTX(PTEVT)
     89 S ORY=+ORY
     90 Q
     91 ;
     92LOC1(ORY,EVT) ; Return default hospital location ^SC( for EVT ptr #100.5
     93 Q:'+EVT
     94 S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,9) S:ORY<1 ORY=+$G(ORL)
     95 Q
     96 ;
     97CHGEVT(ORY,NEWEVT,ORIDS) ; Change order's event
     98 N ORI
     99 S ORI=0
     100 F  S ORI=$O(ORIDS(ORI)) Q:'+ORI  D
     101 . D CHGEVT^OREVNTX(+$G(ORIDS(ORI)),NEWEVT)
     102 Q
     103 ;
     104EMPTY(ORY,PTEVT) ; Return 1 if PTEVT doesn't have any orders
     105 Q:'+PTEVT
     106 S ORY=$$EMPTY^OREVNTX(PTEVT)
     107 Q
     108 ;
     109DELPTEVT(ORY,PTEVT) ; Delete Patient Event in #100.2
     110 Q:'+PTEVT
     111 D CANCEL^OREVNTX(PTEVT)
     112 Q
     113 ;
     114UPDTOR(ORY,PTIFN,ORIFN,PTEVT) ; If delayed order was DCed, then update the EVENT and "AEVNT"
     115 Q  ;Don't ever need to do this!
     116CURSPE(ORY,PTIFN) ; Return current treating specialty
     117 Q:'PTIFN
     118 N SPCID
     119 I $D(^DPT(PTIFN,.103)) D
     120 . S SPCID=$G(^DPT(PTIFN,.103))
     121 . S:SPCID ORY=$P($G(^DIC(45.7,SPCID,0)),U)_U_SPCID
     122 Q
     123DFLTEVT(ORY,PVIFN) ; Return default release event based on provider IFN
     124 N CMEVTLST,IDX
     125 S CMEVTLST="",IDX=0
     126 D GETLST^OREV3(.CMEVTLST)
     127 F  S IDX=$O(CMEVTLST(IDX)) Q:'IDX  D
     128 . I $P($G(CMEVTLST(IDX)),U,2) S ORY=$P($G(CMEVTLST(IDX)),U) Q
     129 Q
     130CMEVTS(ORY,CLOC) ;Return common event list
     131 N IDX,X0,X,LOC
     132 S:CLOC>0 LOC=CLOC
     133 S IDX=0,ORY=""
     134 D GETLST^OREV3(.ORY)
     135 F  S IDX=$O(ORY(IDX)) Q:'IDX  D
     136 . S X0=""
     137 . S:$L($G(^ORD(100.5,+ORY(IDX),0))) X0=$G(^(0))
     138 . I '$L($P(X0,U,2)) D
     139 .. S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2)
     140 . S:$L(X0) ORY(IDX)=+ORY(IDX)_U_X0
     141 Q
     142 ;
     143DELDFLT(ORY,PVIFN) ; Delete default release event
     144 Q:'PVIFN
     145 N ORERR
     146 S ORERR=""
     147 D DEL^XPAR(PVIFN_";VA(200,","OREVNT DEFAULT",1,.ORERR)
     148 Q
     149WRLSTED(LST,LOC,EVTID) ; Return list of dialogs for writing event delayed orders
     150 ; .Y(n): DlgName^ListBox Text
     151WRLST1 N ANENT
     152 S LOC=+$G(LOC)_";SC(" I 'LOC S LOC=""
     153 S ANENT="ALL^USR.`"_DUZ_"^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
     154 N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP
     155 S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS EVENT LIST",EVTID,"I") Q:'MNU
     156 S SEQ=0 F  S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ  D
     157 . S IEN=0 F  S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN  D
     158 . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4)
     159 . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5)
     160 . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5)
     161 . . S:'$L(TXT) TXT=$P(X,U,2)
     162 . . I TYP="M" S:'FID FID=1001
     163 . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT
     164 Q
     165 ;
     166GETDLG(LST,DLGID) ; Return dialog infomation based on the DLGID
     167 N DIEN,DFID,DTXT,DTYP,DGRP,X0,X5
     168 S DLGID=+DLGID
     169 Q:'DLGID
     170 S X0=^ORD(101.41,DLGID,0),X5=$G(^(5))
     171 S DGRP=+$P(X0,U,5),DFID=+$P(X5,U,5),DTXT=$P(X5,U,4),DTYP=$P(X0,U,4)
     172    S:'$L(DTXT) DTXT=$P(X0,U,2)
     173 I $P(X0,U,4)="M" S:'DFID DFID=1001
     174 S LST=DLGID_";"_DFID_";"_DGRP_";"_DTYP_U_DTXT
     175 Q
     176DONE(LST,PTEVT) ; Terminate PTEvt
     177 Q:'PTEVT
     178 D DONE^OREVNTX(PTEVT)
     179 D ACTLOG^OREVNTX(PTEVT,"MN")
     180 Q
     181SETDFLT(ORY,EVT) ;Set personal default event
     182 N ERR,VAL S ERR=""
     183 Q:'$D(^ORD(100.5,EVT,0))
     184 S VAL=$P(^ORD(100.5,EVT,0),U)
     185 D EN^XPAR(DUZ_";VA(200,","OREVNT DEFAULT",1,VAL,ERR)
     186 S ORY=ERR
     187 Q
     188CPACT(ORY,EVT) ; Return True/False to display active orders for copy
     189 ; EVT ptr to #100.5
     190 Q:'EVT
     191 S ORY=0
     192 Q:'$D(^ORD(100.5,EVT,0))
     193 S ORY=$P(^ORD(100.5,EVT,0),U,11)
     194 Q
     195PRMPTID(ORY,PRTNM) ;Return event prompt IEN for OR GTX EVENT
     196 S:$D(^ORD(101.41,"B","OR GTX EVENT")) ORY=$O(^("OR GTX EVENT",0))
     197 Q
     198ISDCOD(ORY,ORIFN) ;True: the order need to be filtered out
     199 N PAS,X3,X0,ORGRPLST,THEGRP,IDX,ODGRP
     200 S (ORY,IDX)=0
     201 Q:'$D(^OR(100,+ORIFN,0))
     202 S X0=$G(^OR(100,+ORIFN,0))
     203 S ODGRP=$P(X0,U,11)
     204 D GETLST^XPAR(.ORGRPLST,"ALL","OREVNT EXCLUDE DGRP")
     205 F  S IDX=$O(ORGRPLST(IDX)) Q:'IDX!ORY  D
     206 . S THEGRP=$P($G(ORGRPLST(IDX)),U,2)
     207 . I $$GRPCHK(THEGRP,ODGRP) S ORY=1
     208 I ORY Q
     209 S PAS=";1;"
     210 S:$D(^OR(100,+ORIFN,3)) X3=^OR(100,+ORIFN,3)
     211 S:(PAS'[(";"_$P(X3,U,3)_";")) ORY=0
     212 Q
     213DEFLTS(ORY,EVTID) ;Return default specialty for EVTID(#100.5)
     214 Q:'+EVTID
     215 N PRTEVT
     216 S PRTEVT=0
     217 S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12)
     218 I PRTEVT>0 S EVTID=PRTEVT
     219 S ORY=$$DEFTS^ORCDADT(EVTID)
     220 Q
     221 ;
     222MULTS(ORY,EVTID) ;Return specialty list for the EVTID(#100.5)
     223 Q:'+EVTID
     224 N I,CNT,X,Y S (I,CNT)=0
     225 N PRTEVT
     226 S PRTEVT=0
     227 S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12)
     228 I PRTEVT>0 S EVTID=PRTEVT
     229 F  S I=$O(^ORD(100.5,+$G(EVTID),"TS",I)) Q:I<1  S X=+$G(^(I,0)) D
     230 . S Y=$$GET1^DIQ(45.7,X_",",.01)
     231 . S CNT=CNT+1,ORY(CNT)=X_U_Y
     232 Q
     233 ;
     234PRTIDS(ORY,IDS) ;Return some prompt ids from #101.41
     235 ; treating specialty Id^attending provider id
     236 N IDX,ORTS,ORATT
     237 S (ORY,ORTS,ORATT)=""
     238 S IDX=$O(^ORD(101.41,"B","OR GTX TREATING SPECIALTY",0))
     239 S:$D(^ORD(101.41,IDX,1)) ORTS=$P($G(^ORD(101.41,IDX,1)),U,2,3)
     240 S IDX=$O(^ORD(101.41,"B","OR GTX PROVIDER",0))
     241 S:$D(^ORD(101.41,IDX,1)) ORATT=$P($G(^ORD(101.41,IDX,1)),U,2,3)
     242 S ORY=ORTS_"~"_ORATT
     243 Q
     244 ;
     245DFLTDLG(ORY,EVTID) ;Return event default dialog IEN
     246 S ORY=0
     247 Q:'$D(^ORD(100.5,+EVTID,0))
     248 S ORY=$P(^ORD(100.5,+EVTID,0),U,4)
     249 Q
     250AUTHMREL(ORY,USER) ;1: user can manual release delayed orders 0: can't
     251 S ORY=$$CANREL^OREV3
     252 Q
     253HAVEPRT(ORY,PTEVT) ;return parent patient event from #100.2
     254 Q:'+PTEVT
     255 S ORY=""
     256 S:$L($G(^ORE(100.2,PTEVT,1))) ORY=$P(^(1),U,5)
     257 Q
     258GRPCHK(DG,AGRP) ;If an order's group belong to DG group
     259 N RST
     260 S RST=0
     261 N ORGRP
     262 D GRP^ORQ1(DG)
     263 S RST=$S($D(ORGRP(AGRP)):1,1:0)
     264 Q RST
     265ODPTEVID(ORY,ORID) ;Return PtEvtID based on the ORID
     266 Q:'$D(^OR(100,+ORID,0))
     267 S ORY=$P($G(^OR(100,+ORID,0)),U,17)
     268 Q
     269COMP(ORY,PTEVT) ;Return 1 or 0 if PTEVT completed or not
     270 Q:'+PTEVT
     271 S ORY=$$COMP^OREVNTX(+PTEVT)
     272 Q
     273ISHDORD(ORY,ORID) ;Return 1 if it's on-hold med order
     274 Q:'+ORID
     275 Q:'$D(^OR(100,+ORID,0))
     276 N STS,HDSTS,ODGP,INPT,OUPT,MEDS,IVMD
     277 S HDSTS=$O(^ORD(100.01,"B","HOLD",0))
     278 S STS=$P($G(^OR(100,+ORID,3)),U,3)
     279 S INPT=$O(^ORD(100.98,"B","UD RX",0))
     280 S OUPT=$O(^ORD(100.98,"B","O RX",0))
     281 S MEDS=$O(^ORD(100.98,"B","RX",0))
     282 S IVMD=$O(^ORD(100.98,"B","IV RX",0))
     283 S ODGP=$P(^OR(100,+ORID,0),U,11)
     284 I (U_INPT_U_OUPT_U_MEDS_U_IVMD_U[U_ODGP_U),(HDSTS=STS) S ORY=1
     285 Q
     286ISPASS(ORY,PTEVTID,EVTTYPE) ;Return 1 if it's a pass event
     287 S ORY=$$EVT^OREVNTX(PTEVTID)
     288 S ORY=$P($G(^ORD(100.5,+ORY,0)),U,7)
     289 I EVTTYPE="T",ORY,ORY<4 S ORY=1
     290 E  S ORY=0
     291 Q
     292ISPASS1(ORY,EVTID,EVTTYPE) ;Return 1 if it's a pass event
     293 S ORY=$P($G(^ORD(100.5,+EVTID,0)),U,7)
     294 I EVTTYPE="T",ORY,ORY<4 S ORY=1
     295 E  S ORY=0
     296 Q
     297DLGIEN(ORY,DLGNAME) ;Return Order Dialog IEN based on name
     298 Q:'$D(^ORD(101.41,"B",DLGNAME))
     299 S ORY=$O(^ORD(101.41,"B",DLGNAME,0))
     300 Q
     301GETSTS(ORY,ORDID) ;Return Order status
     302 Q:'+ORDID
     303 Q:'$D(^OR(100,+ORDID,0))
     304 S ORY=$P($G(^OR(100,+ORDID,3)),U,3)
     305 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORIMO.m

    r613 r623  
    1 ORIMO   ;SLC/JDL - Inpatient medication on outpatient. ; 02/12/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**187,190,195,215,243**;Dec 17, 1997;Build 242
    3 IMOLOC(ORY,ORLOC,ORDFN) ;ORY>=0: LOC is an IMO authorized location
    4         S ORY=-1
    5         N PACH
    6         S PACH=$$PATCH^XPDUTL("PSJ*5.0*111")
    7         Q:'PACH
    8         I $L($TEXT(SDIMO^SDAMA203)) D
    9         . ;#DBIA 4133
    10         . S ORY=$$SDIMO^SDAMA203(ORLOC,ORDFN)
    11         . ;if RSA returns an error then check against Clinic Loc.
    12         . I ORY=-3 D
    13         . .I $P($G(^SC(ORLOC,0)),U,3)'="C" Q
    14         . .I $D(^SC("AE",1,ORLOC))=1 S ORY=1
    15         . K SDIMO(1)
    16         Q
    17         ;
    18 IMOOD(ORY,ORDERID)      ;Is it an IMO order?
    19         Q:'$D(^OR(100,+ORDERID,0))
    20         N PIMO,DGRP,IMOGRP,ISIMO
    21         S (PIMO,DGRP,ISIMO)=0
    22         I $P($G(^OR(100,+ORDERID,0)),U,18)>0 S PIMO=1
    23         S DGRP=$P($G(^OR(100,+ORDERID,0)),U,11)
    24         S IMOGRP=$O(^ORD(100.98,"B","CLINIC ORDERS",""))
    25         I DGRP=IMOGRP S ISIMO=1
    26         I PIMO,ISIMO S ORY=1
    27         Q
    28         ;
    29 ISCLOC(ORY,ALOC)        ;Is it a clinical location
    30         S ORY=0
    31         Q:'$D(^SC(+ALOC,0))
    32         I $P(^SC(+ALOC,0),U,3)="C" S ORY=1
    33         Q
    34 ISIVQO(ORY,DLGID)       ;Is it an IV quick order
    35         S ORY=0
    36         Q:'$D(^ORD(101.41,DLGID,0))
    37         N IVGRP,DLGTYP,DLGGRP
    38         S IVGRP=$O(^ORD(100.98,"B","IV RX",0))
    39         S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4)
    40         S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5)
    41         I (DLGTYP="Q"),(DLGGRP=IVGRP) S ORY=1
    42         Q
     1ORIMO ;SLC/JDL - Inpatient medication on outpatient. ; 07/07/2005
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**187,190,195,215**;Dec 17, 1997
     3IMOLOC(ORY,ORLOC,ORDFN) ;ORY>=0: LOC is an IMO authorized location
     4 S ORY=-1
     5 N PACH
     6 S PACH=$$PATCH^XPDUTL("PSJ*5.0*111")
     7 Q:'PACH
     8 I $L($TEXT(SDIMO^SDAMA203)) D
     9 . ;I $P($G(^SC(ORLOC,0)),U,3)'="C" Q
     10 . ;I $D(^SC("AE",1,ORLOC))=1 S ORY=1
     11 . ;#DBIA 4133
     12 . S ORY=$$SDIMO^SDAMA203(ORLOC,ORDFN)
     13 . K SDIMO(1)
     14 Q
     15 ;
     16IMOOD(ORY,ORDERID) ;Is it an IMO order?
     17 Q:'$D(^OR(100,+ORDERID,0))
     18 N PIMO,DGRP,IMOGRP,ISIMO
     19 S (PIMO,DGRP,ISIMO)=0
     20 I $P($G(^OR(100,+ORDERID,0)),U,18)>0 S PIMO=1
     21 S DGRP=$P($G(^OR(100,+ORDERID,0)),U,11)
     22 S IMOGRP=$O(^ORD(100.98,"B","CLINIC ORDERS",""))
     23 I DGRP=IMOGRP S ISIMO=1
     24 I PIMO,ISIMO S ORY=1
     25 Q
     26 ;
     27ISCLOC(ORY,ALOC) ;Is it a clinical location
     28 S ORY=0
     29 Q:'$D(^SC(+ALOC,0))
     30 I $P(^SC(+ALOC,0),U,3)="C" S ORY=1
     31 Q
     32ISIVQO(ORY,DLGID) ;Is it an IV quick order
     33 S ORY=0
     34 Q:'$D(^ORD(101.41,DLGID,0))
     35 N IVGRP,DLGTYP,DLGGRP
     36 S IVGRP=$O(^ORD(100.98,"B","IV RX",0))
     37 S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4)
     38 S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5)
     39 I (DLGTYP="Q"),(DLGGRP=IVGRP) S ORY=1
     40 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKCHK.m

    r613 r623  
    1 ORKCHK  ; slc/CLA - Main routine called by OE/RR to initiate order checks ; 9/21/07 11:54am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,94,105,123,232,267,243**;Dec 17, 1997;Build 242
    3 EN(ORKY,ORKDFN,ORKA,ORKMODE)    ;initiate order checking
    4         ;ORKY: array of returned msgs in format: ornum^orderchk ien^clin danger^msg
    5         ;ORKDFN: patient dfn
    6         ;ORKA: array of order information in the format:
    7         ; orderable item ien|
    8         ; display group-filler app|
    9         ; nat'l id^nat'l text^nat'l code sys^local id^local text^local code sys|
    10         ; effective d/t|
    11         ; order number|
    12         ; filler data (LR: specimen ien, PS: meds prev ordered during this session in format med1^med2^...)
    13         ;ORKMODE: mode/event trigger (DISPLAY,SELECT,ACCEPT,SESSION,ALL,NOTIF)
    14         ; PS: meds previously ordered during this session med1^med2^...
    15         ;
    16         N ORKQ,ORKN S ORKQ=0,ORKN=1
    17         S:+$G(ORKDFN)<1 ORKY(ORKN)="^^^Order Checking Unavailable - invalid patient id",ORKQ=1,ORKN=ORKN+1
    18         S:'$L($G(ORKMODE)) ORKY(ORKN)="^^^Order Checking Unavailable - invalid mode/event",ORKQ=1,ORKN=ORKN+1
    19         Q:$G(ORKQ)=1
    20         Q:+$G(ORKA)<1
    21         N ORKX,ORKS,DNGR,ORENT,ORKENT,ORKNENT,ORNUM,ORKOFF,ORKTMODE
    22         N ORKADUZ,ORKNDUZ,ORKI,ORKPRIM,ORKNMSG,ORKMSG,ORKLOG,ORKLD,ORKLI,ORKOI
    23         N ORKDG,ORKLPS,ORKPSA,ORKCNT,ORKDGI
    24         ;
    25         ;save array of orders for use in session processing:
    26         M ^TMP("ORKA",$J)=ORKA
    27         ;
    28         ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
    29         ;reliably determined, and many simultaneous outpt locations can occur):
    30         N DFN,ORKLOC
    31         S DFN=ORKDFN,VA200="" D OERR^VADPT
    32         S ORKLOC=+$G(^DIC(42,+VAIN(4),44))
    33         K VA200,VAIN
    34         ;
    35         ;get user's service/section flag:
    36         N ORKSRV
    37         S ORKSRV=$$GET1^DIQ(200,DUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U)
    38         ;
    39         ;log order check debug messages (or not)
    40         S ORKLOG=$$GET^XPAR("DIV^SYS^PKG","ORK DEBUG ENABLE/DISABLE",1,"I")
    41         I $G(ORKLOG)="D" K ^XTMP("ORKLOG") S ^XTMP("ORKLOG",0)=""
    42         I +$P($G(^XTMP("ORKLOG",0)),U,3)>5000 K ^XTMP("ORKLOG")
    43         ;
    44         ;if SESSION mode & pharmacy order occurred in session get unsigned med orders
    45         I ORKMODE="SESSION" D
    46         .S ORKDG=$P(ORKA(1),"|",2)
    47         .I $E($G(ORKDG),1,2)="PS" D
    48         ..S ORKDGI=0,ORKDGI=$O(^ORD(100.98,"B","PHARMACY",ORKDGI))
    49         ..K ^TMP("ORR",$J)
    50         ..D EN^ORQ1(DFN_";DPT(",ORKDGI,11,"","","",0,0)
    51         ..;store unsigned med orders in ^TMP("ORR",$J for processing in ORKPS
    52         ;
    53         ;main processing loop:
    54         S ORKX="" F  S ORKX=$O(ORKA(ORKX)) Q:ORKX=""  D
    55         .S ORKOI=$P(ORKA(ORKX),"|")
    56         .;
    57         .;log debug msgs if parameter is enabled:
    58         .I $G(ORKLOG)="E" D
    59         ..S ORKLD=$$NOW^XLFDT
    60         ..S ORKLI=0
    61         ..I +$P($G(^XTMP("ORKLOG",0)),U,3)<1 S $P(^XTMP("ORKLOG",0),U,3)=0
    62         ..S ORKCNT=$P(^XTMP("ORKLOG",0),U,3)+1
    63         ..S ^XTMP("ORKLOG",0)=$$FMADD^XLFDT(ORKLD,3,"","","")_U_ORKLD_U_ORKCNT
    64         ..S ^XTMP("ORKLOG",ORKLD,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKA(ORKX)
    65         .;
    66         .S ORKDG=$P(ORKA(ORKX),"|",2),ORKTMODE=""
    67         .S ORKENT="USR^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG"
    68         .Q:'$L($G(ORKDG))
    69         .;
    70         .;if pharmacy order and multiple pharmacy orders in session add data node:
    71         .I $E(ORKDG,1,2)="PS",($L($G(ORKPSA))) D
    72         ..S $P(ORKA(ORKX),"|",6)=ORKPSA
    73         .;
    74         .S ORNUM=$P(ORKA(ORKX),"|",5)
    75         .; get correct DUZ for notification processing if in NOTIF mode:
    76         .I ORKMODE="NOTIF" D
    77         ..S:+$G(ORNUM)>0 ORKNDUZ=$$ORDERER^ORQOR2(ORNUM) ;ordering provider
    78         ..S:+$G(ORNUM)<1 ORKNDUZ=$P($$PRIM^ORQPTQ4(ORKDFN),U) ;prim provider
    79         ..I +$G(ORKNDUZ)>0 D
    80         ...S ORKSRV=$$GET1^DIQ(200,ORKNDUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U)
    81         ...S ORKNENT="USR.`"_+ORKNDUZ_"^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG"
    82         ..S:+$G(ORKNDUZ)<1 ORKNENT="LOC.`"_+$G(ORKLOC)_"^DIV^SYS^PKG"
    83         .S ORENT=$S(ORKMODE="NOTIF":ORKNENT,1:ORKENT)
    84         .;
    85         .;If the order is a delayed release order (NOTIF) process all nodes.
    86         .;If it is a renewal, edit or delayed signature order (ALL) process all
    87         .;modes except SESSION which gets processed just before signature:
    88         .I ORKMODE="NOTIF"!(ORKMODE="ALL") S ORKTMODE=ORKMODE D
    89         ..D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;DISPLAY
    90         ..D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;SELECT
    91         ..D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;ACCEPT
    92         ..I ORKMODE="NOTIF" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;SESSION
    93         ..S ORKMODE=ORKTMODE
    94         .;
    95         .;Process regular orders/modes:
    96         .I '$L($G(ORKTMODE)) D
    97         ..I ORKMODE="DISPLAY" D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
    98         ..I ORKMODE="SELECT" D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
    99         ..I ORKMODE="ACCEPT" D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
    100         ..I ORKMODE="SESSION" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
    101         ;
    102         ;set messages into sorting array then into ORKY ORKS("ORK",clinical danger level,oi,msg)=ornum^order check ien^clin danger level^message
    103         S ORKX="",ORKI=1
    104         F  S ORKX=$O(ORKS("ORK",ORKX)) Q:ORKX=""  D
    105         .S ORKY(ORKI)=$E(ORKS("ORK",ORKX),1,250)
    106         .;
    107         .;log debug msgs if parameter is enabled:
    108         .I $G(ORKLOG)="E" D
    109         ..S ORKLI=$G(ORKLI)+1
    110         ..S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKY(ORKI)
    111         ..S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1
    112         .;
    113         .;send moderate and high danger order checks for delayed orders as notifications:
    114         .I ORKMODE="NOTIF" S DNGR=$P(ORKY(ORKI),U,3) I $G(DNGR)<3 D
    115         ..S ORKADUZ="",ORNUM=$P(ORKY(ORKI),U)
    116         ..S:+$G(ORKNDUZ)>0 ORKADUZ(ORKNDUZ)=""
    117         ..S ORKNMSG="Order check: "_$P(ORKY(ORKI),U,4)
    118         ..D EN^ORB3(54,ORKDFN,$G(ORNUM),.ORKADUZ,ORKNMSG,"")
    119         .S ORKI=ORKI+1
    120         ;
    121         K ^TMP("ORKA",$J),^TMP("ORR",$J)
    122         I $G(ORKLOG)="E" D
    123         .S ORKLI=$G(ORKLI)+1
    124         .S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)="LEAVING ORDER CHECKING"
    125         .S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1
    126         D CHKRMT
    127         Q
    128         ;
    129 OI2DD(ORPSA,OROI,ORPSPKG)       ;rtn dispense drugs for a PS OI
    130         N PSOI
    131         Q:'$D(^ORD(101.43,OROI,0))
    132         S PSOI=$P($P(^ORD(101.43,OROI,0),U,2),";")
    133         Q:+$G(PSOI)<1
    134         D DRG^PSSUTIL1(.ORPSA,PSOI,ORPSPKG)
    135         Q
    136 CHKRMT  ;
    137         N I,ORQFLAG
    138         S ORQFLAG=1
    139         S I=0 F  S I=$O(ORKA(I)) Q:'I  I $E($P(ORKA(I),"|",2),1,2)="PS"!($E($P(ORKA(I),"|",2),1,2)="RA") S ORQFLAG=0
    140         Q:$G(ORQFLAG)
    141         Q:'$$HAVEHDR^ORRDI1
    142         Q:$$LDPTTVAL^ORRDI2($G(DFN))
    143         Q:$P($G(^XTMP("ORRDI","PSOO",ORKDFN,0)),U,3)'<0&($P($G(^XTMP("ORRDI","ART",ORKDFN,0)),U,3)'<0)
    144         I $G(ORKMODE)="ACCEPT" D
    145         . N IFN
    146         . S IFN=$O(ORKY(""),-1)+1
    147         . S ORKY(IFN)="^99^2^Remote Order Checking not available - checks done on local data only"
    148         . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1
    149         I $G(ORKMODE)="SESSION" D
    150         . N I,IFN,ORARR
    151         . S IFN=$O(ORKY(""),-1)
    152         . S I=0 F  S I=$O(ORKY(I)) Q:'I  S ORARR(+ORKY(I))=""
    153         . S I=0 F  S I=$O(ORARR(I)) Q:'I  S IFN=IFN+1,ORKY(IFN)=I_"^99^2^Remote Order Checking not available - checks done on local data only"
    154         . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1
    155         Q
     1ORKCHK ; slc/CLA - Main routine called by OE/RR to initiate order checks ; 1/16/07 6:28am
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,94,105,123,232,267**;Dec 17, 1997;Build 6
     3EN(ORKY,ORKDFN,ORKA,ORKMODE) ;initiate order checking
     4 ;ORKY: array of returned msgs in format: ornum^orderchk ien^clin danger^msg
     5 ;ORKDFN: patient dfn
     6 ;ORKA: array of order information in the format:
     7 ; orderable item ien|
     8 ; display group-filler app|
     9 ; nat'l id^nat'l text^nat'l code sys^local id^local text^local code sys|
     10 ; effective d/t|
     11 ; order number|
     12 ; filler data (LR: specimen ien, PS: meds prev ordered during this session in format med1^med2^...)
     13 ;ORKMODE: mode/event trigger (DISPLAY,SELECT,ACCEPT,SESSION,ALL,NOTIF)
     14 ; PS: meds previously ordered during this session med1^med2^...
     15 ;
     16 N ORKQ,ORKN S ORKQ=0,ORKN=1
     17 S:+$G(ORKDFN)<1 ORKY(ORKN)="^^^Order Checking Unavailable - invalid patient id",ORKQ=1,ORKN=ORKN+1
     18 S:'$L($G(ORKMODE)) ORKY(ORKN)="^^^Order Checking Unavailable - invalid mode/event",ORKQ=1,ORKN=ORKN+1
     19 Q:$G(ORKQ)=1
     20 Q:+$G(ORKA)<1
     21 N ORKX,ORKS,DNGR,ORENT,ORKENT,ORKNENT,ORNUM,ORKOFF,ORKTMODE
     22 N ORKADUZ,ORKNDUZ,ORKI,ORKPRIM,ORKNMSG,ORKMSG,ORKLOG,ORKLD,ORKLI,ORKOI
     23 N ORKDG,ORKLPS,ORKPSA,ORKCNT,ORKDGI
     24 ;
     25 ;save array of orders for use in session processing:
     26 M ^TMP("ORKA",$J)=ORKA
     27 ;
     28 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
     29 ;reliably determined, and many simultaneous outpt locations can occur):
     30 N DFN,ORKLOC
     31 S DFN=ORKDFN,VA200="" D OERR^VADPT
     32 S ORKLOC=+$G(^DIC(42,+VAIN(4),44))
     33 K VA200,VAIN
     34 ;
     35 ;get user's service/section flag:
     36 N ORKSRV
     37 S ORKSRV=$$GET1^DIQ(200,DUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U)
     38 ;
     39 ;log order check debug messages (or not)
     40 S ORKLOG=$$GET^XPAR("DIV^SYS^PKG","ORK DEBUG ENABLE/DISABLE",1,"I")
     41 I $G(ORKLOG)="D" K ^XTMP("ORKLOG") S ^XTMP("ORKLOG",0)=""
     42 I +$P($G(^XTMP("ORKLOG",0)),U,3)>5000 K ^XTMP("ORKLOG")
     43 ;
     44 ;if SESSION mode & pharmacy order occurred in session get unsigned med orders
     45 I ORKMODE="SESSION" D
     46 .S ORKDG=$P(ORKA(1),"|",2)
     47 .I $E($G(ORKDG),1,2)="PS" D
     48 ..S ORKDGI=0,ORKDGI=$O(^ORD(100.98,"B","PHARMACY",ORKDGI))
     49 ..K ^TMP("ORR",$J)
     50 ..D EN^ORQ1(DFN_";DPT(",ORKDGI,11,"","","",0,0)
     51 ..;store unsigned med orders in ^TMP("ORR",$J for processing in ORKPS
     52 ;
     53 ;main processing loop:
     54 S ORKX="" F  S ORKX=$O(ORKA(ORKX)) Q:ORKX=""  D
     55 .S ORKOI=$P(ORKA(ORKX),"|")
     56 .;
     57 .;log debug msgs if parameter is enabled:
     58 .I $G(ORKLOG)="E" D
     59 ..S ORKLD=$$NOW^XLFDT
     60 ..S ORKLI=0
     61 ..I +$P($G(^XTMP("ORKLOG",0)),U,3)<1 S $P(^XTMP("ORKLOG",0),U,3)=0
     62 ..S ORKCNT=$P(^XTMP("ORKLOG",0),U,3)+1
     63 ..S ^XTMP("ORKLOG",0)=$$FMADD^XLFDT(ORKLD,3,"","","")_U_ORKLD_U_ORKCNT
     64 ..S ^XTMP("ORKLOG",ORKLD,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKA(ORKX)
     65 .;
     66 .S ORKDG=$P(ORKA(ORKX),"|",2),ORKTMODE=""
     67 .S ORKENT="USR^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG"
     68 .Q:'$L($G(ORKDG))
     69 .;
     70 .;if pharmacy order and multiple pharmacy orders in session add data node:
     71 .I $E(ORKDG,1,2)="PS",($L($G(ORKPSA))) D
     72 ..S $P(ORKA(ORKX),"|",6)=ORKPSA
     73 .;
     74 .S ORNUM=$P(ORKA(ORKX),"|",5)
     75 .; get correct DUZ for notification processing if in NOTIF mode:
     76 .I ORKMODE="NOTIF" D
     77 ..S:+$G(ORNUM)>0 ORKNDUZ=$$ORDERER^ORQOR2(ORNUM) ;ordering provider
     78 ..S:+$G(ORNUM)<1 ORKNDUZ=$P($$PRIM^ORQPTQ4(ORKDFN),U) ;prim provider
     79 ..I +$G(ORKNDUZ)>0 D
     80 ...S ORKSRV=$$GET1^DIQ(200,ORKNDUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U)
     81 ...S ORKNENT="USR.`"_+ORKNDUZ_"^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG"
     82 ..S:+$G(ORKNDUZ)<1 ORKNENT="LOC.`"_+$G(ORKLOC)_"^DIV^SYS^PKG"
     83 .S ORENT=$S(ORKMODE="NOTIF":ORKNENT,1:ORKENT)
     84 .;
     85 .;If the order is a delayed release order (NOTIF) process all nodes.
     86 .;If it is a renewal, edit or delayed signature order (ALL) process all
     87 .;modes except SESSION which gets processed just before signature:
     88 .I ORKMODE="NOTIF"!(ORKMODE="ALL") S ORKTMODE=ORKMODE D
     89 ..D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;DISPLAY
     90 ..D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;SELECT
     91 ..D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;ACCEPT
     92 ..I ORKMODE="NOTIF" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)  ;SESSION
     93 ..S ORKMODE=ORKTMODE
     94 .;
     95 .;Process regular orders/modes:
     96 .I '$L($G(ORKTMODE)) D
     97 ..I ORKMODE="DISPLAY" D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
     98 ..I ORKMODE="SELECT" D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
     99 ..I ORKMODE="ACCEPT" D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
     100 ..I ORKMODE="SESSION" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE)
     101 ;
     102 ;set messages into sorting array then into ORKY ORKS("ORK",clinical danger level,oi,msg)=ornum^order check ien^clin danger level^message
     103 S ORKX="",ORKI=1
     104 F  S ORKX=$O(ORKS("ORK",ORKX)) Q:ORKX=""  D
     105 .S ORKY(ORKI)=$E(ORKS("ORK",ORKX),1,250)
     106 .;
     107 .;log debug msgs if parameter is enabled:
     108 .I $G(ORKLOG)="E" D
     109 ..S ORKLI=$G(ORKLI)+1
     110 ..S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKY(ORKI)
     111 ..S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1
     112 .;
     113 .;send moderate and high danger order checks for delayed orders as notifications:
     114 .I ORKMODE="NOTIF" S DNGR=$P(ORKY(ORKI),U,3) I $G(DNGR)<3 D
     115 ..S ORKADUZ="",ORNUM=$P(ORKY(ORKI),U)
     116 ..S:+$G(ORKNDUZ)>0 ORKADUZ(ORKNDUZ)=""
     117 ..S ORKNMSG="Order check: "_$P(ORKY(ORKI),U,4)
     118 ..D EN^ORB3(54,ORKDFN,$G(ORNUM),.ORKADUZ,ORKNMSG,"")
     119 .S ORKI=ORKI+1
     120 ;
     121 K ^TMP("ORKA",$J),^TMP("ORR",$J)
     122 I $G(ORKLOG)="E" D
     123 .S ORKLI=$G(ORKLI)+1
     124 .S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)="LEAVING ORDER CHECKING"
     125 .S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1
     126 D CHKRMT
     127 Q
     128 ;
     129OI2DD(ORPSA,OROI,ORPSPKG) ;rtn dispense drugs for a PS OI
     130 N PSOI
     131 Q:'$D(^ORD(101.43,OROI,0))
     132 S PSOI=$P($P(^ORD(101.43,OROI,0),U,2),";")
     133 Q:+$G(PSOI)<1
     134 D DRG^PSSUTIL1(.ORPSA,PSOI,ORPSPKG)
     135 Q
     136CHKRMT ;
     137 N I,ORQFLAG
     138 S ORQFLAG=1
     139 S I=0 F  S I=$O(ORKA(I)) Q:'I  I $E($P(ORKA(I),"|",2),1,2)="PS"!($E($P(ORKA(I),"|",2),1,2)="RA") S ORQFLAG=0
     140 Q:$G(ORQFLAG)
     141 Q:'$$HAVEHDR^ORRDI1
     142 Q:$$LDPTTVAL^ORRDI2($G(DFN))
     143 Q:$P($G(^XTMP("ORRDI","PSOO",ORKDFN,0)),U,3)'<0&($P($G(^XTMP("ORRDI","ART",ORKDFN,0)),U,3)'<0)
     144 I $G(ORKMODE)="ACCEPT" D
     145 . N IFN
     146 . S IFN=$O(ORKY(""),-1)+1
     147 . S ORKY(IFN)="^99^2^Order check performed on local data only"
     148 . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1
     149 I $G(ORKMODE)="SESSION" D
     150 . N I,IFN,ORARR
     151 . S IFN=$O(ORKY(""),-1)
     152 . S I=0 F  S I=$O(ORKY(I)) Q:'I  S ORARR(+ORKY(I))=""
     153 . S I=0 F  S I=$O(ORARR(I)) Q:'I  S IFN=IFN+1,ORKY(IFN)=I_"^99^2^Order check performed on local data only."
     154 . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1
     155 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m

    r613 r623  
    1 ORKLR   ; slc/CLA - Order checking support procedure for lab orders ;7/23/96  14:31
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105,243**;Dec 17, 1997;Build 242
    3         Q
    4 DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN)    ; return duplicate lab order info
    5         N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL
    6         ;get lab id from orderable item (OI):
    7         S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)=""
    8         ;expand into child-level lab identifiers if children exist for this OI:
    9         ;if children found, set panel flag to '1':
    10         S LRID="" F  S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID=""  S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1
    11         ;get duplicate date range-beginning date/time for this OI:
    12         S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U)
    13         Q:DDT=0  ;if dup range for this OI = zero, don't process dup order oc
    14         ;
    15         ;get all lab orders since dup beg d/t:
    16         S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN))
    17         K ^TMP("ORR",$J)
    18         D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0)
    19         N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
    20         S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1
    21         F  S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1  D
    22         .S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4)
    23         .Q:+$G(ORN)=+$G(ORIFN)  ;quit current order # = dup order #
    24         .;break into child orders if they exist:
    25         .I $D(^OR(100,ORN,2,0)) D  ;child orders exist
    26         ..S ORNC=0 F  S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC=""  D
    27         ...Q:+$G(ORNC)=+$G(ORIFN)  ;quit current order # = dup order #
    28         ...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL))
    29         .I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL))
    30         K ^TMP("ORR",$J)
    31         Q
    32 DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check
    33         N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ
    34         S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2)
    35         ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed:
    36         I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q
    37         ;
    38         ;get specimen for this order:
    39         S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN")
    40         Q:'$L($G(ORSP))  ;quit if no specimen found
    41         ;get orderable item for this order:
    42         S OROI=$$OI^ORQOR2(ORN)
    43         Q:'$L($G(OROI))  ;quit if no orderable item found
    44         ;get lab id and check against ordered array ORL
    45         S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D
    46         .S LRID="" F  S LRID=$O(ORL(LRID)) Q:LRID=""  I LRID=LRIDX D  ;dup!
    47         ..;
    48         ..;quit if order results entered in lab as "cancelled":
    49         ..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
    50         ..S ORX=0 F  S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1  D
    51         ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
    52         ..Q:+$G(ORQ)=1  ;quit if lab test cancelled in lab
    53         ..;
    54         ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
    55         ..;get most recent lab results:
    56         ..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)
    57         ..;
    58         ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
    59         ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_"  *Most recent result: "_$P(RCNT,U,2)_"*"
    60         ;get children lab ids and check against ordered array  ORL
    61         S LRIDX="" F  S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX=""  D
    62         .S LRIDXC=LRIDX_";"_ORSP
    63         .S LRID="" F  S LRID=$O(ORL(LRID)) Q:LRID=""  I LRID=LRIDXC D  ;dup!
    64         ..;
    65         ..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
    66         ..S ORX=0 F  S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1  D
    67         ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
    68         ..Q:+$G(ORQ)=1  ;quit if lab test cancelled in lab
    69         ..;
    70         ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
    71         ..;get most recent lab results:
    72         ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP))
    73         ..;
    74         ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
    75         ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_"  *Most recent result: "_$P(RCNT,U,2)_"*"
    76         Q
    77 RECNTWBC(ORDFN,ORDAYS)  ;extrinsic function to return most recent WBC within <ORDAYS> in format:
    78         ;test id^result units flag ref range collection d/t
    79         N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE
    80         Q:'$L($G(ORDFN)) "0^"
    81         D NOW^%DTC
    82         I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
    83         K %
    84         S:'$L($G(BDT)) BDT=1  ;if no ORDAYS, set BDT to '1' to search all days
    85         S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC")
    86         Q:'$D(ORY) "0^"  ;quit if no link between WBC and local lab test
    87         Q:$G(LABFILE)'=60 "0^"
    88         S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN")
    89         Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec
    90         Q:$G(SPECFILE)'=61 "0^"
    91         F ORI=1:1:ORY I +$G(WBCRSLT)<1 D
    92         .S TEST=$P(ORY(ORI),U)
    93         .Q:+$G(TEST)<1
    94         .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D
    95         ..S SPECIMEN=$P(ORX(ORJ),U)
    96         ..Q:+$G(SPECIMEN)<1
    97         ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN)
    98         ..Q:'$L($G(ORZ))
    99         ..S CDT=$P(ORZ,U,7)
    100         ..I CDT'<BDT S WBCRSLT=1
    101         Q:+$G(WBCRSLT)<1 "0^"
    102         Q $P(ORZ,U,3)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_")  "_$$FMTE^XLFDT(CDT,"2P")
    103         ;
    104 CLOZLABS(ORDFN,ORDAYS,ORCLOZ)   ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not
    105         ;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC
    106         ; result^recent ANC flag;recent ANC result^formatted WBC and ANC results
    107         ;
    108         N BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF
    109         Q:'$L($G(ORDFN)) "0^"
    110         I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","")
    111         S:'$L($G(BDT)) BDT=1  ;if no ORDAYS, set BDT to '1' to search all days
    112         ;
    113         K LAB
    114         D EN^PSODRG(ORCLOZ)  ;pharmacy api rtns Lab file ptrs for WBC, ANC
    115         Q:$G(LAB("NOT"))=0 "0^"  ;medication is not clozapine
    116         ;Q:$G(LAB("BAD TEST"))=0 "0^"  ;one or both lab tests aren't mapped
    117         ;S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U)
    118         ;S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U)
    119         ;
    120         K ^TMP($J,"PSO")
    121         D CL1^YSCLTST2(ORDFN,ORDAYS)
    122         I $D(^TMP($J,"PSO")) D
    123         .N INVDT
    124         .S INVDT=$O(^TMP($J,"PSO",0))
    125         .Q:'INVDT
    126         .S WBC=$P($G(^TMP($J,"PSO",INVDT)),U)/1000
    127         .S ANC=$P($G(^TMP($J,"PSO",INVDT)),U,2)/1000
    128         .I WBC S WBCF=1
    129         .I ANC S ANCF=1
    130         .I $L(WBC)=1 S WBC=WBC_".0"
    131         .I $L(ANC)=1 S ANC=ANC_".0"
    132         .S WBCRSLT="WBC "_WBC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]"
    133         .S ANCRSLT="ANC "_ANC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]"
    134         ;
    135         K LAB
    136         Q "1^"_$G(WBCF,0)_";"_$G(WBC)_"^"_$G(ANCF,0)_";"_$G(ANC)_"^"_$G(WBCRSLT)_"  "_$G(ANCRSLT)
     1ORKLR ; slc/CLA - Order checking support procedure for lab orders ;7/23/96  14:31
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105**;Dec 17, 1997
     3 Q
     4DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info
     5 N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL
     6 ;get lab id from orderable item (OI):
     7 S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)=""
     8 ;expand into child-level lab identifiers if children exist for this OI:
     9 ;if children found, set panel flag to '1':
     10 S LRID="" F  S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID=""  S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1
     11 ;get duplicate date range-beginning date/time for this OI:
     12 S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U)
     13 Q:DDT=0  ;if dup range for this OI = zero, don't process dup order oc
     14 ;
     15 ;get all lab orders since dup beg d/t:
     16 S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN))
     17 K ^TMP("ORR",$J)
     18 D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0)
     19 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
     20 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1
     21 F  S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1  D
     22 .S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4)
     23 .Q:+$G(ORN)=+$G(ORIFN)  ;quit current order # = dup order #
     24 .;break into child orders if they exist:
     25 .I $D(^OR(100,ORN,2,0)) D  ;child orders exist
     26 ..S ORNC=0 F  S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC=""  D
     27 ...Q:+$G(ORNC)=+$G(ORIFN)  ;quit current order # = dup order #
     28 ...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL))
     29 .I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL))
     30 K ^TMP("ORR",$J)
     31 Q
     32DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check
     33 N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ
     34 S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2)
     35 ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed:
     36 I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q
     37 ;
     38 ;get specimen for this order:
     39 S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN")
     40 Q:'$L($G(ORSP))  ;quit if no specimen found
     41 ;get orderable item for this order:
     42 S OROI=$$OI^ORQOR2(ORN)
     43 Q:'$L($G(OROI))  ;quit if no orderable item found
     44 ;get lab id and check against ordered array ORL
     45 S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D
     46 .S LRID="" F  S LRID=$O(ORL(LRID)) Q:LRID=""  I LRID=LRIDX D  ;dup!
     47 ..;
     48 ..;quit if order results entered in lab as "cancelled":
     49 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
     50 ..S ORX=0 F  S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1  D
     51 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
     52 ..Q:+$G(ORQ)=1  ;quit if lab test cancelled in lab
     53 ..;
     54 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
     55 ..;get most recent lab results:
     56 ..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)
     57 ..;
     58 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
     59 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_"  *Most recent result: "_$P(RCNT,U,2)_"*"
     60 ;get children lab ids and check against ordered array  ORL
     61 S LRIDX="" F  S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX=""  D
     62 .S LRIDXC=LRIDX_";"_ORSP
     63 .S LRID="" F  S LRID=$O(ORL(LRID)) Q:LRID=""  I LRID=LRIDXC D  ;dup!
     64 ..;
     65 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
     66 ..S ORX=0 F  S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1  D
     67 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
     68 ..Q:+$G(ORQ)=1  ;quit if lab test cancelled in lab
     69 ..;
     70 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
     71 ..;get most recent lab results:
     72 ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP))
     73 ..;
     74 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
     75 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_"  *Most recent result: "_$P(RCNT,U,2)_"*"
     76 Q
     77RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within <ORDAYS> in format:
     78 ;test id^result units flag ref range collection d/t
     79 N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE
     80 Q:'$L($G(ORDFN)) "0^"
     81 D NOW^%DTC
     82 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
     83 K %
     84 S:'$L($G(BDT)) BDT=1  ;if no ORDAYS, set BDT to '1' to search all days
     85 S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC")
     86 Q:'$D(ORY) "0^"  ;quit if no link between WBC and local lab test
     87 Q:$G(LABFILE)'=60 "0^"
     88 S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN")
     89 Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec
     90 Q:$G(SPECFILE)'=61 "0^"
     91 F ORI=1:1:ORY I +$G(WBCRSLT)<1 D
     92 .S TEST=$P(ORY(ORI),U)
     93 .Q:+$G(TEST)<1
     94 .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D
     95 ..S SPECIMEN=$P(ORX(ORJ),U)
     96 ..Q:+$G(SPECIMEN)<1
     97 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN)
     98 ..Q:'$L($G(ORZ))
     99 ..S CDT=$P(ORZ,U,7)
     100 ..I CDT'<BDT S WBCRSLT=1
     101 Q:+$G(WBCRSLT)<1 "0^"
     102 Q $P(ORZ,U,3)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_")  "_$$FMTE^XLFDT(CDT,"2P")
     103 ;
     104CLOZLABS(ORDFN,ORDAYS,ORCLOZ) ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not
     105 ;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC
     106 ; result^recent ANC flag;recent ANC result^formatted WBC and ANC results
     107 ;
     108 N BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF
     109 Q:'$L($G(ORDFN)) "0^"
     110 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","")
     111 S:'$L($G(BDT)) BDT=1  ;if no ORDAYS, set BDT to '1' to search all days
     112 ;
     113 K LAB
     114 D EN^PSODRG(ORCLOZ)  ;pharmacy api rtns Lab file ptrs for WBC, ANC
     115 Q:$G(LAB("NOT"))=0 "0^"  ;medication is not clozapine
     116 Q:$G(LAB("BAD TEST"))=0 "0^"  ;one or both lab tests aren't mapped
     117 S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U)
     118 S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U)
     119 ;
     120 S WBCRSLT=$$LOCL^ORQQLR1(ORDFN,WBC,WBCSPEC)
     121 S WBCCDT=$P(WBCRSLT,U,7)
     122 S WBC=$P(WBCRSLT,U,3)
     123 I $L(WBC) D
     124 .S WBCRSLT="WBC: "_WBC_" ["_$$FMTE^XLFDT(WBCCDT,"""2P""")_"]"
     125 E  S WBCRSLT="WBC: no results found"
     126 I $L(WBC),(WBCCDT>BDT) S WBCF=1
     127 S:$G(WBCF)'=1 WBCF=0
     128 ;
     129 S ANCRSLT=$$LOCL^ORQQLR1(ORDFN,ANC,ANCSPEC)
     130 S ANCCDT=$P(ANCRSLT,U,7)
     131 S ANC=$P(ANCRSLT,U,3)
     132 I $L(ANC),(ANCCDT=WBCCDT) D  ;ANC from same collection d/t as WBC
     133 .S ANC=(WBC*ANC)/100
     134 .S ANCRSLT="ANC: "_ANC_" ["_$$FMTE^XLFDT(ANCCDT,"""2P""")_"]"
     135 E  S ANCRSLT="ANC: no results found"
     136 I $L(ANC),(ANCCDT>BDT) S ANCF=1
     137 S:$G(ANCF)'=1 ANCF=0
     138 ;
     139 K LAB
     140 Q "1^"_WBCF_";"_WBC_"^"_ANCF_";"_ANC_"^"_WBCRSLT_"  "_ANCRSLT

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP.m

    r613 r623  
    1 ORLP    ; SLC/CLA - Manager for Team List options ; 5/30/08 6:28am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98,243**;Dec 17, 1997;Build 242
    3         ;
    4 CLEAR   ; From TM, MERG^ORLP1, END^ORLP0.
    5         K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0
    6         Q
    7         ;
    8 TM      ; From option ORLP TEAM ADD - create/add a team list.
    9         N ORLTYP
    10         D CLEAR
    11         W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users.  You may now create a new team list"
    12         W !,"or add autolinks, users and/or patients to an existing team list.  Autolinks",!,"automatically add or remove patients with ADT movements.  Users on the list"
    13         W !,"may receive notifications regarding patients on the same list.  Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",!
    14         D ASKLIST,END
    15         Q
    16         ;
    17 ASKLIST ; Ask for team list.
    18         ; NOTE: For new entries, TYPE field is required and trigger
    19         ;       stuffs CREATOR field with DUZ of current user.
    20         ;
    21 AL      N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY
    22         N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: "
    23         D ^DIR
    24         I '$D(X)!$D(DIRUT) K DIR,DIRUT Q
    25         S ORLTNAM=$$CHKNAM(Y)                 ; Check for duplication.
    26         K DIR
    27         N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC
    28         I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q   ; User aborted or problem.
    29         I +Y,'+$G(^OR(100.21,+Y,11)) S ^OR(100.21,+Y,11)="0^"
    30         ; Check for "Personal" lists (and not a new entry):
    31         I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!,"     Personal lists cannot be edited here.",! G AL
    32         S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC
    33         ; Check for entry of team type (new team entry):
    34         I $P(TEAM,U,3) D  Q
    35         .I $P(TEAM(0),U,2)="" D
    36         ..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called.
    37         ..N DIE S DIE=ORROOT,DA=+Y,DR="1  Enter type:  ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q
    38         .S (ORLTYP,OROWNER)=""
    39         .S ORLTYP=$P(^OR(100.21,+TEAM,0),U,2) Q:'$L(ORLTYP)
    40         .; Check for "P" type, ask for user/owner input:
    41         .I ORLTYP="P" D OWNER^ORLP1 ; Sets OROWNER variable.
    42         .I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q
    43         .;
    44         .; Allow further editing of autolink type teams:
    45         .I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D  Q
    46         .. D ASKLINK,ASKUSER,ASKDEV,ASKSUB
    47         .;
    48         .; Proceed with editing for "TM" type teams:
    49         .D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV
    50         ;
    51         ; For existing teams, display team type:
    52         W !,"  Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)")
    53         ;
    54         ; Lock before allowing editing:
    55         I $O(^OR(100.21,+TEAM,10,0)) L +^OR(100.21,+TEAM):3 I '$T W !?5,"  Another user is editing this entry." Q
    56         ;
    57         ; Allow applicable editing for all types but "TM" teams:
    58         I $P(TEAM(0),U,2)'="TM" D
    59         . D ASKLINK,ASKUSER,ASKDEV
    60         . ;
    61         . ; Editing of "subscription" attribute for "TA" and "MRAL" teams:
    62         . I $P(TEAM(0),U,2)["A" D
    63         . . D ASKSUB
    64         ;
    65         ; Proceed with editing for "TM" type teams:
    66         I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV
    67         Q
    68         ;
    69 ASKLINK ; Ask for autolinks.
    70         N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME
    71         W !
    72         F  K DIC,DA,DUOUT D  I LVP<1 Q
    73         .S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")="  Enter team autolink: "
    74         .D ^DIC S LVP=Y I Y<1 Q
    75         .I $P($G(Y),U,3)=1 D
    76         ..S LNAME=Y(0,0)
    77         ..I LVP["VA(200" F  D  Q:'$D(Y)
    78         ...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !,"  This field is required in order for Provider autolinks to work correctly.",!,"  Please answer the question."
    79         ..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2)
    80         ..; For clinics, take a fork in the road:
    81         ..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q
    82         ..; For autolinks besides clinics, truck on:
    83         ..D ADDLPTS
    84         Q
    85         ;
    86 ADDLPTS ; Add patients linked to autolink.
    87         W !
    88         W !,"       [ADT movements linked to "
    89         W !,"          ",LNAME
    90         W !,"        will now automatically add patients to this list.]"
    91         S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0
    92         W !!,"       Adding patients linked to ",LNAME,"..."
    93         W !
    94         I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q
    95         I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q
    96         I FILE="^VA(200," D  Q
    97         . ; Variable LVPT determines if provider pointer is for:
    98         . ;    B - Both Primary and Attending
    99         . ;    A - Attending
    100         . ;    P - Primary
    101         . I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q
    102         . I LVPT["P" D LOOPTS("APR",+LINK) Q
    103         . I LVPT["A" D LOOPTS("AAP",+LINK)
    104         I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q
    105         Q
    106         ;
    107 BYCL(CLINIC)    ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment.
    108         ;
    109         ; Called by ASKLINK.
    110         ;
    111         ; Variables used:
    112         ;
    113         ;    CLINIC  = Clinic to search.
    114         ;    ORLIST  = Array, returned by call to PTCL^SCAPMC.
    115         ;    ORERR   = Array for errors, returned by call to PTCL^SCAPMC.
    116         ;    ORRET  = Flag for problem with PTCL^SCAPMC call.
    117         ;    RESULT  = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
    118         ;    RCD     = Holder for each record in ^TMP of PTCL^SCAPMC.
    119         ;    DFN     = Patient IEN.
    120         ;    ALCNT   = Count of autolink patients added.
    121         ;    DUPCNT  = Count of duplicate patients already on list.
    122         ;    X       = Temp value holder variable.
    123         ;
    124         N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET
    125         ;
    126         ; Assign clinic variable:
    127         S CLINIC=$P(CLINIC,"^",2)
    128         S CLINIC=$P(CLINIC,";")
    129         ;
    130         ; Keep user informed:
    131         W !
    132         W !,"       [Patient enrollments linked to "
    133         W !,"          ",LNAME
    134         W !,"        will now automatically add patients to this list.]"
    135         W !
    136         W !,"       Adding patients enrolled in ",LNAME,"..."
    137         W !
    138         ;
    139         ; Process the Autolink entries:
    140         K ^TMP("SC TMP LIST") ; Clean up potential leftover data.
    141         S ORRET=1
    142         S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
    143         I $L($G(RESULT)) D   ; Make sure something was returned.
    144         .I RESULT>0 S ORRET=0 ; Was return value 1 or more?
    145         I ORRET W !,"  Error in processing - patients will not be added." Q  ; Abort if there's a problem.
    146         ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
    147         ;
    148         ; Write the patients to the OE/RR LIST file:
    149         S ALCNT=0  ; Initialize autolink counter.
    150         S DUPCNT=0 ; Initialize duplicate counter.
    151         S RCD=0    ; Initialize to start with first data record.
    152         F  S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD  D  ; Each record.
    153         .S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^")          ; Patient IEN.
    154         .S X=DFN_";DPT(" ; Add ";DPT(" to patient string.
    155         .I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q  ; This patient already on list - increment dupe counter.
    156         .S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^"
    157         .K DIC,DA,DO,DD
    158         .S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L"
    159         .D FILE^DICN
    160         .I +X S ALCNT=ALCNT+1 ; Increment counter.
    161         .Q  ; Loop for each record in ^TMP file.
    162         ;
    163         ; Give user the results:
    164         I ALCNT>0 W !,"       "_ALCNT_" patient(s) added to list."
    165         I ALCNT=0 W !,"       No linked patients found."
    166         I DUPCNT>0 W !,"       "_DUPCNT_" patient(s) already on list."
    167         W !
    168         K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries.
    169         ;
    170         Q
    171         ;
    172 LOOPTS(REF,DEX) ;
    173         S ORLPT=0 F  S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0  S X=ORLPT_";DPT(" D ADDLOOP
    174         I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR"
    175         I +X W !,$S(+CNT:"       "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:"       Linked patients already on list.")
    176         E  W "       No linked patients found."
    177         W !
    178         K DEX,FILE,MSG,REF,X,Y
    179         Q
    180         ;
    181 ASKUSER ; From ASKLIST - ask for providers/users.
    182         Q:$D(DTOUT)!($D(DUOUT))
    183         W !
    184         S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^"
    185         K DIC,DA
    186         S DLAYGO=100.212,DA(1)=+TEAM
    187         S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ"
    188         S DIC("A")="  Enter team provider/user: "
    189         ; SLC/PKS - Next line added on 4/11/2000:
    190         S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
    191         F  D  Q:Y<1
    192         .D ^DIC
    193         .I '(Y<1) W !
    194         K DIC,DA,DLAYGO
    195         Q
    196         ;
    197 ASKDEV  ; From ASKLIST - ask for device.
    198         ;
    199         ; New, by PKS - 7/29/99:
    200         Q:$D(DTOUT)!($D(DUOUT))  ; Previous interaction fail?
    201         W !
    202         N DIE,DR
    203         S DIE="^OR(100.21,"
    204         S DA=+TEAM
    205         S DR="1.5  Enter device: "
    206         D ^DIE ; Writes to DEVICE field.
    207         K DIE
    208         Q
    209         ;
    210 ASKSUB  ; From ASKLIST - Ask re: subscription status.
    211         ; (PKS - 8/1999)
    212         ;
    213         Q:$D(DTOUT)!($D(DUOUT))  ; Previous interaction fail?
    214         W !
    215         N DIE,DR
    216         S DIE="^OR(100.21,"
    217         S DA=+TEAM
    218         S DR="1.7  Enter subscription status: "
    219         D ^DIE ; Writes to SUBSCRIBE field.
    220         K DIE
    221         ;
    222         Q
    223         ;
    224 STOR    ; From SEQ^ORLP0 - store list in 100.21.
    225         Q:'$D(DUZ)!('ORCNT)
    226         I '$D(TEAM),($D(Y)#2) S TEAM=Y
    227         S DLAYGO=100.21
    228         L +^OR(100.21,+TEAM)
    229         S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1  I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP
    230         I $G(X)>0 S MSG=$S(CNT=0:"       Patient(s) already on list.",1:"       "_CNT_" patient(s) added.") W !?5,MSG
    231         E  W !?5,"       No patients found."
    232         I CNT>0 W !?5,"  Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..."
    233         L -^OR(100.12,+TEAM)
    234         Q
    235         ;
    236 ADDLOOP ; From STOR, LOOPTS - add patients.
    237         Q:$D(^OR(100.21,+TEAM,10,"B",X))  ; Quit if on list.
    238         S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^"
    239         K DIC,DA,DO,DD
    240         S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L"
    241         D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1
    242         Q
    243         ;
    244 CHKNAM(X)       ; Check for duplicate entry.
    245         N DIC
    246         S X=$G(X)
    247         S DIC="^OR(100.21,"
    248         D ^DIC
    249         S X=+Y
    250         Q X
    251         ;
    252 END     ;
    253         I $G(TEAM) L -^OR(100.21,+TEAM)
    254         ;
    255 END1    K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT
    256         Q
    257         ;
     1ORLP ; SLC/CLA - Manager for Team List options ; [1/12/01 1:54pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98**;Dec 17, 1997
     3 ;
     4CLEAR ; From TM, MERG^ORLP1, END^ORLP0.
     5 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0
     6 Q
     7 ;
     8TM ; From option ORLP TEAM ADD - create/add a team list.
     9 N ORLTYP
     10 D CLEAR
     11 W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users.  You may now create a new team list"
     12 W !,"or add autolinks, users and/or patients to an existing team list.  Autolinks",!,"automatically add or remove patients with ADT movements.  Users on the list"
     13 W !,"may receive notifications regarding patients on the same list.  Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",!
     14 D ASKLIST,END
     15 Q
     16 ;
     17ASKLIST ; Ask for team list.
     18 ; NOTE: For new entries, TYPE field is required and trigger
     19 ;       stuffs CREATOR field with DUZ of current user.
     20 ;
     21AL N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY
     22 N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: "
     23 D ^DIR
     24 I '$D(X)!$D(DIRUT) K DIR,DIRUT Q
     25 S ORLTNAM=$$CHKNAM(Y)                 ; Check for duplication.
     26 K DIR
     27 N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC
     28 I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q   ; User aborted or problem.
     29 ; Check for "Personal" lists (and not a new entry):
     30 I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!,"     Personal lists cannot be edited here.",! G AL
     31 S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC
     32 ; Check for entry of team type (new team entry):
     33 I $P(TEAM,U,3) D  Q
     34 .I $P(TEAM(0),U,2)="" D
     35 ..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called.
     36 ..N DIE S DIE=ORROOT,DA=+Y,DR="1  Enter type:  ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q
     37 .S (ORLTYP,OROWNER)=""
     38 .S ORLTYP=$P(^OR(100.21,+TEAM,0),U,2) Q:'$L(ORLTYP)
     39 .; Check for "P" type, ask for user/owner input:
     40 .I ORLTYP="P" D OWNER^ORLP1 ; Sets OROWNER variable.
     41 .I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q
     42 .;
     43 .; Allow further editing of autolink type teams:
     44 .I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D  Q
     45 .. D ASKLINK,ASKUSER,ASKDEV,ASKSUB
     46 .;
     47 .; Proceed with editing for "TM" type teams:
     48 .D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV
     49 ;
     50 ; For existing teams, display team type:
     51 W !,"  Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)")
     52 ;
     53 ; Lock before allowing editing:
     54 I $O(^OR(100.21,+TEAM,10,0)) L +^OR(100.21,+TEAM):3 I '$T W !?5,"  Another user is editing this entry." Q
     55 ;
     56 ; Allow applicable editing for all types but "TM" teams:
     57 I $P(TEAM(0),U,2)'="TM" D
     58 . D ASKLINK,ASKUSER,ASKDEV
     59 . ;
     60 . ; Editing of "subscription" attribute for "TA" and "MRAL" teams:
     61 . I $P(TEAM(0),U,2)["A" D
     62 . . D ASKSUB
     63 ;
     64 ; Proceed with editing for "TM" type teams:
     65 I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV
     66 Q
     67 ;
     68ASKLINK ; Ask for autolinks.
     69 N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME
     70 W !
     71 F  K DIC,DA,DUOUT D  I LVP<1 Q
     72 .S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")="  Enter team autolink: "
     73 .D ^DIC S LVP=Y I Y<1 Q
     74 .I $P($G(Y),U,3)=1 D
     75 ..S LNAME=Y(0,0)
     76 ..I LVP["VA(200" F  D  Q:'$D(Y)
     77 ...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !,"  This field is required in order for Provider autolinks to work correctly.",!,"  Please answer the question."
     78 ..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2)
     79 ..; For clinics, take a fork in the road:
     80 ..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q
     81 ..; For autolinks besides clinics, truck on:
     82 ..D ADDLPTS
     83 Q
     84 ;
     85ADDLPTS ; Add patients linked to autolink.
     86 W !
     87 W !,"       [ADT movements linked to "
     88 W !,"          ",LNAME
     89 W !,"        will now automatically add patients to this list.]"
     90 S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0
     91 W !!,"       Adding patients linked to ",LNAME,"..."
     92 W !
     93 I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q
     94 I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q
     95 I FILE="^VA(200," D  Q
     96 . ; Variable LVPT determines if provider pointer is for:
     97 . ;    B - Both Primary and Attending
     98 . ;    A - Attending
     99 . ;    P - Primary
     100 . I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q
     101 . I LVPT["P" D LOOPTS("APR",+LINK) Q
     102 . I LVPT["A" D LOOPTS("AAP",+LINK)
     103 I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q
     104 Q
     105 ;
     106BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment.
     107 ;
     108 ; Called by ASKLINK.
     109 ;
     110 ; Variables used:
     111 ;
     112 ;    CLINIC  = Clinic to search.
     113 ;    ORLIST  = Array, returned by call to PTCL^SCAPMC.
     114 ;    ORERR   = Array for errors, returned by call to PTCL^SCAPMC.
     115 ;    ORRET  = Flag for problem with PTCL^SCAPMC call.
     116 ;    RESULT  = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
     117 ;    RCD     = Holder for each record in ^TMP of PTCL^SCAPMC.
     118 ;    DFN     = Patient IEN.
     119 ;    ALCNT   = Count of autolink patients added.
     120 ;    DUPCNT  = Count of duplicate patients already on list.
     121 ;    X       = Temp value holder variable.
     122 ;
     123 N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET
     124 ;
     125 ; Assign clinic variable:
     126 S CLINIC=$P(CLINIC,"^",2)
     127 S CLINIC=$P(CLINIC,";")
     128 ;
     129 ; Keep user informed:
     130 W !
     131 W !,"       [Patient enrollments linked to "
     132 W !,"          ",LNAME
     133 W !,"        will now automatically add patients to this list.]"
     134 W !
     135 W !,"       Adding patients enrolled in ",LNAME,"..."
     136 W !
     137 ;
     138 ; Process the Autolink entries:
     139 K ^TMP("SC TMP LIST") ; Clean up potential leftover data.
     140 S ORRET=1
     141 S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
     142 I $L($G(RESULT)) D   ; Make sure something was returned.
     143 .I RESULT>0 S ORRET=0 ; Was return value 1 or more?
     144 I ORRET W !,"  Error in processing - patients will not be added." Q  ; Abort if there's a problem.
     145 ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
     146 ;
     147 ; Write the patients to the OE/RR LIST file:
     148 S ALCNT=0  ; Initialize autolink counter.
     149 S DUPCNT=0 ; Initialize duplicate counter.
     150 S RCD=0    ; Initialize to start with first data record.
     151 F  S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD  D  ; Each record.
     152 .S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^")          ; Patient IEN.
     153 .S X=DFN_";DPT(" ; Add ";DPT(" to patient string.
     154 .I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q  ; This patient already on list - increment dupe counter.
     155 .S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^"
     156 .K DIC,DA,DO,DD
     157 .S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L"
     158 .D FILE^DICN
     159 .I +X S ALCNT=ALCNT+1 ; Increment counter.
     160 .Q  ; Loop for each record in ^TMP file.
     161 ;
     162 ; Give user the results:
     163 I ALCNT>0 W !,"       "_ALCNT_" patient(s) added to list."
     164 I ALCNT=0 W !,"       No linked patients found."
     165 I DUPCNT>0 W !,"       "_DUPCNT_" patient(s) already on list."
     166 W !
     167 K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries.
     168 ;
     169 Q
     170 ;
     171LOOPTS(REF,DEX) ;
     172 S ORLPT=0 F  S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0  S X=ORLPT_";DPT(" D ADDLOOP
     173 I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR"
     174 I +X W !,$S(+CNT:"       "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:"       Linked patients already on list.")
     175 E  W "       No linked patients found."
     176 W !
     177 K DEX,FILE,MSG,REF,X,Y
     178 Q
     179 ;
     180ASKUSER ; From ASKLIST - ask for providers/users.
     181 Q:$D(DTOUT)!($D(DUOUT))
     182 W !
     183 S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^"
     184 K DIC,DA
     185 S DLAYGO=100.212,DA(1)=+TEAM
     186 S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ"
     187 S DIC("A")="  Enter team provider/user: "
     188 ; SLC/PKS - Next line added on 4/11/2000:
     189 S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
     190 F  D  Q:Y<1
     191 .D ^DIC
     192 .I '(Y<1) W !
     193 K DIC,DA,DLAYGO
     194 Q
     195 ;
     196ASKDEV ; From ASKLIST - ask for device.
     197 ;
     198 ; New, by PKS - 7/29/99:
     199 Q:$D(DTOUT)!($D(DUOUT))  ; Previous interaction fail?
     200 W !
     201 N DIE,DR
     202 S DIE="^OR(100.21,"
     203 S DA=+TEAM
     204 S DR="1.5  Enter device: "
     205 D ^DIE ; Writes to DEVICE field.
     206 K DIE
     207 Q
     208 ;
     209ASKSUB ; From ASKLIST - Ask re: subscription status.
     210 ; (PKS - 8/1999)
     211 ;
     212 Q:$D(DTOUT)!($D(DUOUT))  ; Previous interaction fail?
     213 W !
     214 N DIE,DR
     215 S DIE="^OR(100.21,"
     216 S DA=+TEAM
     217 S DR="1.7  Enter subscription status: "
     218 D ^DIE ; Writes to SUBSCRIBE field.
     219 K DIE
     220 ;
     221 Q
     222 ;
     223STOR ; From SEQ^ORLP0 - store list in 100.21.
     224 Q:'$D(DUZ)!('ORCNT)
     225 I '$D(TEAM),($D(Y)#2) S TEAM=Y
     226 S DLAYGO=100.21
     227 L +^OR(100.21,+TEAM)
     228 S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1  I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP
     229 I $G(X)>0 S MSG=$S(CNT=0:"       Patient(s) already on list.",1:"       "_CNT_" patient(s) added.") W !?5,MSG
     230 E  W !?5,"       No patients found."
     231 I CNT>0 W !?5,"  Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..."
     232 L -^OR(100.12,+TEAM)
     233 Q
     234 ;
     235ADDLOOP ; From STOR, LOOPTS - add patients.
     236 Q:$D(^OR(100.21,+TEAM,10,"B",X))  ; Quit if on list.
     237 S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^"
     238 K DIC,DA,DO,DD
     239 S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L"
     240 D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1
     241 Q
     242 ;
     243CHKNAM(X) ; Check for duplicate entry.
     244 N DIC
     245 S X=$G(X)
     246 S DIC="^OR(100.21,"
     247 D ^DIC
     248 S X=+Y
     249 Q X
     250 ;
     251END ;
     252 I $G(TEAM) L -^OR(100.21,+TEAM)
     253 ;
     254END1 K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT
     255 Q
     256 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDPS.m

    r613 r623  
    1 ORMBLDPS        ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;6/16/08
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254,243**;Dec 17, 1997;Build 242
    3 PTR(NAME)       ; -- Returns ptr value of prompt in Dialog file
    4         Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
    5         ;
    6 NVA     ; -- new Non-VA Meds order
    7         N NVA S NVA=1
    8 OUT     ; -- new Outpt Meds order [same as UD, +3 fields]
    9 UD      ; -- new Inpt (Unit Dose) Meds order
    10         N ADMIN,OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT,OITXT,OITXT2
    11         N QT7,SCHTYPE
    12         S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag
    13         S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different
    14         S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG")
    15         S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES")
    16         S SCHTYPE=$$PTR("SCHEDULE TYPE")
    17         S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE")
    18         S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1")
    19         S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN")
    20         S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|"
    21         I +$G(NVA)=1 G NVA1
    22 UD1     S I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:I'>0  D
    23         . S X=$G(ORDIALOG(DOSE,I))
    24         . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"")
    25         . S QT2=$$ESC($G(ORDIALOG(SCHED,I)))_$S(OUTPT:"",1:"&"_$G(ORDIALOG(ADMIN,I)))
    26         . S QT3=$$HL7DUR
    27         . S QT1=$S($L(X):$P(X,"&",1,6),1:"")
    28         . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2)
    29         . S QT7=$G(ORDIALOG(SCHTYPE,I))
    30         . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~"
    31         . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_U_QT7_U_$$INSTR_U_QT9
    32         ;
    33 NVA1    I +$G(NVA)=1 D
    34         . S I=1 ;only one dosage possible for non-va meds
    35         . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I))
    36         . S QT1=$S($L(X):$P(X,"&",1,6),1:"")
    37         . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2)
    38         . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~"
    39         . S J=J+1,ORC(J)=QT1_U_$$ESC(QT2)_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9
    40         ;
    41         I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2
    42         S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0
    43         F J=1:1:ORC S Y=ORC(J) D  ;add to ORMSG(4)
    44         . I $L(@X)+$L(Y)'>245 S @X=@X_Y
    45         . E  S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y))
    46         I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD"
    47         S OITXT=$$USID^ORMBLD($G(ORDIALOG(OI,1)))
    48         S OITXT2=$P(OITXT,U,1,4)_U_$$ESC($P(OITXT,U,5))_U_$P(OITXT,U,6,99)
    49         S ORMSG(5)="RXO|"_OITXT2_"|||||||||"_$G(DISPENSE)
    50 UD2     I $G(OUTPT) D
    51         . N QTY,REFS,DSPY
    52         . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY")
    53         . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1))
    54         S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D
    55         . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J
    56         . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,PROVCOMM,1,J,0)))
    57         . S K=0 F  S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0  S K=K+1,ORMSG(6,K)=$G(^(J,0))
    58         I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D
    59         . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J
    60         . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0))
    61         . S K=0 F  S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0  S K=K+1,ORMSG(I,K)=$G(^(J,0))
    62 UD3     S J=0 F  S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0  S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J)))
    63         I $D(^OR(100,IFN,9)) D ORDCHKS
    64         S I=I+1,ORMSG(I)=$$ZRX(IFN,OUTPT)
    65         I $G(OUTPT) D  ;add SC data
    66         . N OR5 S OR5=$G(^OR(100,IFN,5))
    67         . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q
    68         . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC")
    69         ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
    70         D DG1^ORWDBA3($G(IFN),"I",I)
    71         I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D
    72         . S I=I+1 D ZRN(IFN,.ORMSG,I)
    73         Q
    74         ;
    75 INSTR() ; -- Return text instructions for QT-8, instance I
    76         N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5)
    77         I $G(ORDIALOG(DRUG,1)),$L(Y) Q $$ESC(Y)
    78         S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D
    79         . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I))
    80         . S:$L(UNT) Y=Y_" "_UNT ;old format
    81         Q $$ESC(Y)
    82         ;
    83 HL7DUR()        ; -- Returns HL7 form of duration X
    84         N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I))
    85         S X1=+$G(X),Y="" G:X1'>0 HDQ
    86         S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99)
    87         S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1
    88 HDQ     Q Y
    89         ;
    90 IV      ; -- new IV Meds order
    91         N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST
    92         N IVLIMIT ; duratioin or total volume for IV order
    93         N IVTYPE,IVZRX,X,CNT,ROUTE,ORBCMA,DFN
    94         S IVLIMIT=$$PTR("DURATION")
    95         S IVTYPE=$G(ORDIALOG(+$$PTR("IV TYPE"),1))
    96         I IVTYPE="",$P($G(^OR(100,IFN,3)),U,11)="B" D
    97         .S IVTYPE=$$MOB^ORMBLDP1(IFN,+$P($G(^OR(100,IFN,0)),U,2))
    98         .D RESP^ORCSAVE2(IFN,"OR GTX IV TYPE",IVTYPE)
    99         S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE")
    100         S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
    101         S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME")
    102         S SCHTYPE=$$PTR("SCHEDULE TYPE")
    103         S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1))
    104         ;I IVTYPE="",$G(ORDIALOG(+$$PTR("SCHEDULE"),1))="" S IVTYPE="C"
    105         I IVTYPE="I" S QT=U_$$ESC($G(ORDIALOG(+$$PTR("SCHEDULE"),1)))_"&"_$G(ORDIALOG(+$$PTR("ADMIN TIMES"),1))_"^^^^"
    106         I IVTYPE="C" S QT="^^^^^"
    107         ;S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^"
    108         S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2)
    109         S $P(ORMSG(4),"|",8)=QT
    110         S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different
    111         S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_$$ESC(RATE) ;strip any trailing spaces
    112         S IVLIMIT=$G(ORDIALOG(IVLIMIT,1))
    113         I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT^ORMBLDP1(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE
    114         S I=5 I $L($G(ORDIALOG(WP,1))) D
    115         . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J
    116         . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,WP,1,J,0)))
    117         . S K=0 F  S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0  S K=K+1,ORMSG(6,K)=^(J,0)
    118         ;S I=I+1,ORMSG(I)=$$RXR(+$$PTR("ROUTE"))
    119         S ROUTE=+$$PTR("ROUTE")
    120         S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,1)))
    121 IV1     S INST=0 F  S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0  D
    122         . S X1="B",X2=+$G(ORDIALOG(SOLN,INST))
    123         . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix
    124         . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML")
    125         I $O(ORDIALOG(ADDS,0)) D
    126         . S INST=0 F  S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0  D
    127         . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST))
    128         . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2)
    129         I $D(^OR(100,IFN,9)) D ORDCHKS
    130         S IVZRX=$$ZRX(IFN,0)
    131         S CNT=0
    132         F X=1:1:$L(IVZRX) I $E(IVZRX,X)="|" S CNT=CNT+1
    133         I CNT<6 F X=CNT:1:5 S IVZRX=IVZRX_"|"
    134         S I=I+1,ORMSG(I)=IVZRX_IVTYPE
    135         ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
    136         D DG1^ORWDBA3($G(IFN),"I",I)
    137         Q
    138         ;
    139 RXR(ROUTE)      ; -- Returns RXR segment
    140         N IEN,NAME
    141         I +ROUTE=0 Q "RXR|^^^^^99PSR"
    142         K ^TMP($J,"ORMBLDPS RXR")
    143         D ALL^PSS51P2(+ROUTE,,,,"ORMBLDPS RXR")
    144         S NAME=^TMP($J,"ORMBLDPS RXR",+ROUTE,.01)
    145         ;N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01)
    146         K ^TMP($J,"ORMBLDPS RXR")
    147         Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR"
    148         ;
    149 ZRX(IFN,OUTPT)  ; -- Returns ZRX segment
    150         N NATURE,TYPE,ORIG,PSORIG,ROUTING,ZRX
    151         S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12)
    152         S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code
    153         S PSORIG="" I (TYPE=1)!(TYPE=2) D
    154         . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4))
    155         . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order
    156         S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N")
    157         S ROUTING=$G(ORDIALOG($$PTR("ROUTING"),1))
    158         ;AGP FIX FOR PROBLEM WITH ROUTING BE SET TO DAY SUPPLY ONCE ROOT CAUSE
    159         ;IS FOUND THIS CODE WILL BE REMOVE
    160         I OUTPT=1,ROUTING'="",ROUTING>0 S ROUTING="M"
    161         I $G(OUTPT) S ZRX=ZRX_"|"_ROUTING_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"")
    162         Q ZRX
    163         ;
    164 ZRN(IFN,ORMSG,I)        ; -- Set ZRN segment
    165         N ST,ZRN,J,K,TXT
    166         S ORMSG(I)="ZRN|N|"
    167         S ST=$$PTR("STATEMENTS")
    168         I $L($G(ORDIALOG(ST,1))) D
    169         . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J
    170         . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0))
    171         . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT
    172         . F  S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0  S TXT=$G(^(J,0)) D
    173         . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT
    174         Q
    175         ;
    176 ORDCHKS ; -- Include order checks in OBX segments
    177         N OC,X,X1 S OC=0
    178         F  S OC=$O(^OR(100,IFN,9,OC)) Q:OC'>0  S X=$G(^(OC,0)),X1=$G(^(1)) D
    179         . S I=I+1,ORMSG(I)="OBX|"_OC_"|TX|^^^"_+X_"^^99OCX||"_$$ESC($S($L(X1):X1,1:$P(X,U,3)))_"|||||||||"_$$FMTHL7^XLFDT($P(X,U,6))_"||"_$P(X,U,5)
    180         . I $L($P(X,U,4)) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$$ESC($P(X,U,4))
    181         Q
    182         ;
    183 HL7UNIT(X)      ; -- Return coded element for volume/strength units
    184         N I,UNIT,Y
    185         F I=1:1:$L(X) I $E(X,I)?1A Q  ; first letter
    186         S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y=""
    187         F I=1:1:14 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q
    188         Q Y
    189         ;
    190 VER(IFN)        ; -- Send msg for nurse-verified orders
    191         N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I"  ;Inpt only
    192         S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2))
    193         S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10))
    194         S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT)
    195         D MSG^XQOR("OR EVSEND PS",.ORMSG)
    196         Q
    197         ;
    198 REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request
    199         N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O"
    200         S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10))
    201         S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2))
    202         S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC)
    203         S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT)
    204         S ORMSG(5)="ZRX||||"_ROUTING
    205         D MSG^XQOR("OR EVSEND PS",.ORMSG)
    206         Q
    207 ESC(STR)        ;
    208         Q $$ESC^ORHLESC(STR,"~|\&^")
     1ORMBLDPS ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;11:26 AM  2 Apr 2001
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254**;Dec 17, 1997
     3PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
     4 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     5 ;
     6NVA ; -- new Non-VA Meds order
     7 N NVA S NVA=1
     8OUT ; -- new Outpt Meds order
     9 ;    fall through to UD: same msg, +3 fields
     10UD ; -- new Inpt (Unit Dose) Meds order
     11 N OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT
     12 S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag
     13 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different
     14 S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG")
     15 S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE")
     16 S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE")
     17 S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1")
     18 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN")
     19 S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|"
     20 I +$G(NVA)=1 G NVA1
     21UD1 S I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:I'>0  D
     22 . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I))
     23 . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"")
     24 . S QT1=$S($L(X):$P(X,"&",1,6),1:"")
     25 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2)
     26 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~"
     27 . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9
     28 ;
     29NVA1 I +$G(NVA)=1 D
     30 . S I=1 ;only one dosage possible for non-va meds
     31 . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I))
     32 . S QT1=$S($L(X):$P(X,"&",1,6),1:"")
     33 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2)
     34 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~"
     35 . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9
     36 ;
     37 I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2
     38 S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0
     39 F J=1:1:ORC S Y=ORC(J) D  ;add to ORMSG(4)
     40 . I $L(@X)+$L(Y)'>245 S @X=@X_Y
     41 . E  S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y))
     42 I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD"
     43 S ORMSG(5)="RXO|"_$$USID^ORMBLD($G(ORDIALOG(OI,1)))_"|||||||||"_$G(DISPENSE)
     44UD2 I $G(OUTPT) D
     45 . N QTY,REFS,DSPY
     46 . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY")
     47 . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1))
     48 S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D
     49 . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J
     50 . S I=6,ORMSG(6)="NTE|6|P|"_$G(^TMP("ORWORD",$J,PROVCOMM,1,J,0))
     51 . S K=0 F  S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0  S K=K+1,ORMSG(6,K)=$G(^(J,0))
     52 I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D
     53 . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J
     54 . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0))
     55 . S K=0 F  S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0  S K=K+1,ORMSG(I,K)=$G(^(J,0))
     56UD3 S J=0 F  S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0  S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J)))
     57 I $D(^OR(100,IFN,9)) D ORDCHKS
     58 S I=I+1,ORMSG(I)=$$ZRX(IFN)
     59 I $G(OUTPT) D  ;add SC data
     60 . N OR5 S OR5=$G(^OR(100,IFN,5))
     61 . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q
     62 . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC")
     63 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
     64 D DG1^ORWDBA3($G(IFN),"I",I)
     65 I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D
     66 . S I=I+1 D ZRN(IFN,.ORMSG,I)
     67 Q
     68 ;
     69INSTR()  ; -- Return text instructions for QT-8, instance I
     70 N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5)
     71 I $G(ORDIALOG(DRUG,1)),$L(Y) Q Y
     72 S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D
     73 . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I))
     74 . S:$L(UNT) Y=Y_" "_UNT ;old format
     75 Q Y
     76 ;
     77HL7DUR()  ; -- Returns HL7 form of duration X
     78 N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I))
     79 S X1=+$G(X),Y="" G:X1'>0 HDQ
     80 S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99)
     81 S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1
     82HDQ Q Y
     83 ;
     84IV ; -- new IV Meds order
     85 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST
     86 N IVLIMIT ; duratioin or total volume for IV order
     87 S IVLIMIT=$$PTR("DURATION")
     88 S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE")
     89 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
     90 S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME")
     91 S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1))
     92 S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^"
     93 S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2) S $P(ORMSG(4),"|",8)=QT
     94 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different
     95 S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_RATE ;strip any trailing spaces
     96 S IVLIMIT=$G(ORDIALOG(IVLIMIT,1))
     97 I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE
     98 S I=5 I $L($G(ORDIALOG(WP,1))) D
     99 . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J
     100 . S I=6,ORMSG(6)="NTE|6|P|"_$G(^TMP("ORWORD",$J,WP,1,J,0))
     101 . S K=0 F  S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0  S K=K+1,ORMSG(6,K)=^(J,0)
     102IV1 S INST=0 F  S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0  D
     103 . S X1="B",X2=+$G(ORDIALOG(SOLN,INST))
     104 . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix
     105 . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML")
     106 I $O(ORDIALOG(ADDS,0)) D
     107 . S INST=0 F  S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0  D
     108 . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST))
     109 . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2)
     110 I $D(^OR(100,IFN,9)) D ORDCHKS
     111 S I=I+1,ORMSG(I)=$$ZRX(IFN)
     112 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
     113 D DG1^ORWDBA3($G(IFN),"I",I)
     114 Q
     115 ;
     116RXR(ROUTE) ; -- Returns RXR segment
     117 N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01)
     118 Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR"
     119 ;
     120ZRX(IFN) ; -- Returns ZRX segment
     121 N NATURE,TYPE,ORIG,PSORIG,ZRX
     122 S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12)
     123 S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code
     124 S PSORIG="" I (TYPE=1)!(TYPE=2) D
     125 . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4))
     126 . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order
     127 S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N")
     128 I $G(OUTPT) S ZRX=ZRX_"|"_$G(ORDIALOG($$PTR("ROUTING"),1))_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"")
     129 Q ZRX
     130 ;
     131ZRN(IFN,ORMSG,I) ; -- Set ZRN segment
     132 N ST,ZRN,J,K,TXT
     133 S ORMSG(I)="ZRN|N|"
     134 S ST=$$PTR("STATEMENTS")
     135 I $L($G(ORDIALOG(ST,1))) D
     136 . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J
     137 . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0))
     138 . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT
     139 . F  S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0  S TXT=$G(^(J,0)) D
     140 . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT
     141 Q
     142 ;
     143ORDCHKS ; -- Include order checks in OBX segments
     144 N OC,X,X1 S OC=0
     145 F  S OC=$O(^OR(100,IFN,9,OC)) Q:OC'>0  S X=$G(^(OC,0)),X1=$G(^(1)) D
     146 . S I=I+1,ORMSG(I)="OBX|"_OC_"|TX|^^^"_+X_"^^99OCX||"_$S($L(X1):X1,1:$P(X,U,3))_"|||||||||"_$$FMTHL7^XLFDT($P(X,U,6))_"||"_$P(X,U,5)
     147 . I $L($P(X,U,4)) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$P(X,U,4)
     148 Q
     149 ;
     150HL7UNIT(X) ; -- Return coded element for volume/strength units
     151 N I,UNIT,Y
     152 F I=1:1:$L(X) I $E(X,I)?1A Q  ; first letter
     153 S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y=""
     154 F I=1:1:13 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q
     155 Q Y
     156 ;
     157HL7TIME(X) ; -- Return HL7 formatted duration
     158 N I,Y S Y=""
     159 F I=1:1:$L(X) I $E(X,I)?1A S Y=$$UP^XLFSTR($E(X,I)) Q  ; first letter
     160 S Y=Y_+X
     161 Q Y
     162 ;
     163VER(IFN) ; -- Send msg for nurse-verified orders
     164 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I"  ;Inpt only
     165 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2))
     166 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10))
     167 S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT)
     168 D MSG^XQOR("OR EVSEND PS",.ORMSG)
     169 Q
     170 ;
     171REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request
     172 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O"
     173 S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10))
     174 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2))
     175 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC)
     176 S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT)
     177 S ORMSG(5)="ZRX||||"_ROUTING
     178 D MSG^XQOR("OR EVSEND PS",.ORMSG)
     179 Q
     180HL7IVLMT(STR) ;
     181 N VAL,UNIT,IVLMT,TVAL,LEN
     182 S (UNIT,IVLMT)="",VAL=0
     183 I $E($$LOW^XLFSTR(STR))="f" D
     184 . S VAL=$P(STR," ",2)
     185 . S UNIT=$E($P(STR," ",3))
     186 I $E($$LOW^XLFSTR(STR))="w" D
     187 . S TVAL=$P(STR," ",4)      ;pull data in total example 0.5ml
     188 . S VAL=+TVAL     ;this will strip out leading zero and alpha 00.5L becomes .5 or 05.5 becomes 5.5
     189 . S LEN=$F(TVAL,VAL)        ;get length up to alphas or trailing zeros
     190 . I $P(VAL,".")="" S VAL=0_VAL  ;make sure decimal values have only one leading zero .5 becomes 0.5.
     191 . F  S UNIT=$E(TVAL,LEN) Q:((UNIT'=0)&(UNIT'="."))  D    ;get first alpha m or l
     192 . . S LEN=LEN+1
     193 I $L(UNIT),$L(VAL) S IVLMT=$$LOW^XLFSTR(UNIT)_VAL
     194 Q IVLMT
     195 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDRA.m

    r613 r623  
    1 ORMBLDRA        ; SLC/MKB - Build outgoing Radiology ORM msgs ;05/30/06  11:30AM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**75,97,190,195,243**;Dec 17, 1997;Build 242
    3 HL7DATE(DATE)   ; -- FM -> HL7 format
    4         Q $$FMTHL7^XLFDT(DATE)  ;**97
    5         ;
    6 PTR(NAME)       ; -- Returns ptr value of prompt in Dialog file
    7         Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
    8         ;
    9 EN      ; -- Segments for new Radiology order
    10         N ORSEX,OI,START,IP,URG,ILOC,MODE,CATG,PREOP,PREG,MODS,CLHIST,PROV,REASON,QT,I,J,Z,J0,LIN,RA75
    11         S OI=$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1))
    12         S START=$P($G(^OR(100,IFN,0)),U,8),IP=$G(ORDIALOG($$PTR("YES/NO"),1))
    13         S URG=$P($G(^ORD(101.42,+$G(ORDIALOG($$PTR("URGENCY"),1)),0)),U,2)
    14         S ILOC=$G(ORDIALOG($$PTR("IMAGING LOCATION"),1))
    15         S MODE=$G(ORDIALOG($$PTR("MODE OF TRANSPORT"),1))
    16         S CATG=$G(ORDIALOG($$PTR("CATEGORY"),1))
    17         S PREOP=$G(ORDIALOG($$PTR("PRE-OP SCHEDULED DATE/TIME"),1))
    18         S PREG=$G(ORDIALOG($$PTR("PREGNANT"),1))
    19         S REASON=$G(ORDIALOG($$PTR("STUDY REASON"),1))
    20         S MODS=$$PTR("MODIFIERS"),CLHIST=$$PTR("WORD PROCESSING 1")
    21         S MODS=$$MULT(MODS) S:ILOC ILOC=ILOC_U_$P($G(^RA(79.1,+ILOC,0)),U)
    22         S MODE=$S(MODE="A":"WALK",MODE="P":"PORT",MODE="S":"CART",1:"WHLC")
    23         S PREG=$S(PREG="Y":"YES",PREG="N":"NO",1:"UNKNOWN")
    24         S QT="^^^"_$$HL7DATE(START)_"^^"_URG,$P(ORMSG(4),"|",8)=QT
    25         S PROV=+$G(ORDIALOG($$PTR("PROVIDER"),1)) S:PROV $P(ORMSG(4),"|",12)=PROV
    26         S RA75=$$PATCH^XPDUTL("RA*5.0*75")
    27         S ORMSG(5)="OBR||||"_$$USID^ORMBLD(OI)_"||||||||"_$S(IP:"isolation",1:"")_"||||||"_MODS_"|"_ILOC_"|||||||||||"_MODE,I=5
    28         I +RA75 S $P(ORMSG(5),"|",32)=U_REASON
    29         ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
    30         D DG1^ORWDBA3($G(IFN),"I",I)
    31 OBX     S J0=0
    32         I 'RA75 D
    33         . S I=I+1,ORMSG(I)="OBX|1|TX|2000.02^CLINICAL HISTORY^AS4|1|"_"REASON FOR STUDY: "_REASON
    34         . S $P(LIN,"-",55)=""
    35         . S I=I+1,ORMSG(I)="OBX|2|TX|2000.02^CLINICAL HISTORY^AS4|1|"_LIN
    36         . S J0=2
    37         S J=0 F  S J=$O(^TMP("ORWORD",$J,CLHIST,1,J)) Q:J'>0  S I=I+1,J0=J0+1,ORMSG(I)="OBX|"_J0_"|TX|2000.02^CLINICAL HISTORY^AS4|1|"_^(J,0)
    38         S ORSEX=$P($G(^DPT(+ORVP,0)),U,2)
    39         S:ORSEX="F" I=I+1,ORMSG(I)="OBX|1|TX|2000.33^PREGNANT^AS4||"_PREG
    40         S:PREOP I=I+1,ORMSG(I)="OBX|1|TS|^PRE-OP SCHEDULED DATE/TIME||"_$$HL7DATE(PREOP)
    41         I "CS"[CATG S Z=$$PTR("CONTRACT/SHARING SOURCE"),I=I+1,ORMSG(I)="OBX|1|CE|34^CONTRACT/SHARING SOURCE^99DD||"_+$G(ORDIALOG(Z,1))_U_$P($G(^DIC(34,+$G(ORDIALOG(Z,1)),0)),U)
    42         I CATG="R" S Z=$$PTR("RESEARCH SOURCE"),I=I+1,ORMSG(I)="OBX|1|TX|^RESEARCH SOURCE||"_$G(ORDIALOG(Z,1))
    43         Q
    44 MULT(M) ; -- Returns string of MODIFIER~MODIFIER~...
    45         N I,X S X="" Q:'$O(ORDIALOG(M,0)) X
    46         S I=$O(ORDIALOG(M,0)),X=$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U)
    47         F  S I=$O(ORDIALOG(M,I)) Q:I'>0  S X=X_"~"_$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U)
    48         Q X
     1ORMBLDRA ; SLC/MKB - Build outgoing Radiology ORM msgs ;11/17/00  11:14
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**75,97,190,195**;Dec 17, 1997
     3HL7DATE(DATE) ; -- FM -> HL7 format
     4 Q $$FMTHL7^XLFDT(DATE)  ;**97
     5 ;
     6PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
     7 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     8 ;
     9EN ; -- Segments for new Radiology order
     10 N ORSEX,OI,START,IP,URG,ILOC,MODE,CATG,PREOP,PREG,MODS,CLHIST,PROV,QT,I,J,Z
     11 S OI=$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1))
     12 S START=$P($G(^OR(100,IFN,0)),U,8),IP=$G(ORDIALOG($$PTR("YES/NO"),1))
     13 S URG=$P($G(^ORD(101.42,+$G(ORDIALOG($$PTR("URGENCY"),1)),0)),U,2)
     14 S ILOC=$G(ORDIALOG($$PTR("IMAGING LOCATION"),1))
     15 S MODE=$G(ORDIALOG($$PTR("MODE OF TRANSPORT"),1))
     16 S CATG=$G(ORDIALOG($$PTR("CATEGORY"),1))
     17 S PREOP=$G(ORDIALOG($$PTR("PRE-OP SCHEDULED DATE/TIME"),1))
     18 S PREG=$G(ORDIALOG($$PTR("PREGNANT"),1))
     19 S MODS=$$PTR("MODIFIERS"),CLHIST=$$PTR("WORD PROCESSING 1")
     20 S MODS=$$MULT(MODS) S:ILOC ILOC=ILOC_U_$P($G(^RA(79.1,+ILOC,0)),U)
     21 S MODE=$S(MODE="A":"WALK",MODE="P":"PORT",MODE="S":"CART",1:"WHLC")
     22 S PREG=$S(PREG="Y":"YES",PREG="N":"NO",1:"UNKNOWN")
     23 S QT="^^^"_$$HL7DATE(START)_"^^"_URG,$P(ORMSG(4),"|",8)=QT
     24 S PROV=+$G(ORDIALOG($$PTR("PROVIDER"),1)) S:PROV $P(ORMSG(4),"|",12)=PROV
     25 S ORMSG(5)="OBR||||"_$$USID^ORMBLD(OI)_"||||||||"_$S(IP:"isolation",1:"")_"||||||"_MODS_"|"_ILOC_"|||||||||||"_MODE,I=5
     26 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
     27 D DG1^ORWDBA3($G(IFN),"I",I)
     28OBX S J=0 F  S J=$O(^TMP("ORWORD",$J,CLHIST,1,J)) Q:J'>0  S I=I+1,ORMSG(I)="OBX|"_J_"|TX|2000.02^CLINICAL HISTORY^AS4|1|"_^(J,0)
     29 S ORSEX=$P($G(^DPT(+ORVP,0)),U,2)
     30 S:ORSEX="F" I=I+1,ORMSG(I)="OBX|1|TX|2000.33^PREGNANT^AS4||"_PREG
     31 S:PREOP I=I+1,ORMSG(I)="OBX|1|TS|^PRE-OP SCHEDULED DATE/TIME||"_$$HL7DATE(PREOP)
     32 I "CS"[CATG S Z=$$PTR("CONTRACT/SHARING SOURCE"),I=I+1,ORMSG(I)="OBX|1|CE|34^CONTRACT/SHARING SOURCE^99DD||"_+$G(ORDIALOG(Z,1))_U_$P($G(^DIC(34,+$G(ORDIALOG(Z,1)),0)),U)
     33 I CATG="R" S Z=$$PTR("RESEARCH SOURCE"),I=I+1,ORMSG(I)="OBX|1|TX|^RESEARCH SOURCE||"_$G(ORDIALOG(Z,1))
     34 Q
     35 ;
     36MULT(M) ; -- Returns string of MODIFIER~MODIFIER~...
     37 N I,X S X="" Q:'$O(ORDIALOG(M,0)) X
     38 S I=$O(ORDIALOG(M,0)),X=$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U)
     39 F  S I=$O(ORDIALOG(M,I)) Q:I'>0  S X=X_"~"_$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U)
     40 Q X

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m

    r613 r623  
    1 ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04  09:21
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN1     ; -- tasked entry point
    6         Q:'$G(DFN)  Q:$D(DGPMPC)  Q:DGPMT=4!(DGPMT=5)  ;skip lodger mvts
    7         N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I
    8         S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO=""
    9         S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")=""
    10         F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)=""
    11         D ^%ZTLOAD ;D EN^ORYDGPM
    12         Q
    13         ;
    14 EN      ; -- main entry point
    15         S:$D(ZTQUEUED) ZTREQ="@"
    16         Q:'$G(DFN)  Q:$D(DGPMPC)  Q:DGPMT=4!(DGPMT=5)
    17         I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195
    18         I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 Q  ;195 edits processed after new JEH
    19         N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context
    20         N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT
    21         S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D  Q  ;deleted
    22         . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
    23         . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0))
    24         . D ACTLOG^OREVNTX(OREVT,"DL")
    25 A       ;
    26         S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1))
    27         S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0)
    28         S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL)
    29         S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)=""
    30         S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y)
    31         N OREVNTLK S OREVNTLK=""  ;JEH
    32         S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") ; Lock
    33         I OREVENT=-1 D EN1 Q  ;195 Can't lock, retry
    34         S OREVNTLK=OREVENT  ; save routine copy of ifn JEH
    35         I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D   ;edited
    36         . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
    37         . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0))
    38         . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement
    39         . I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q  ;no change
    40         . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1
    41         I $G(DONE) D FINISHED Q  ; unlock and clean up before quit IFNjeh
    42 B       ;
    43         I '$G(DGPMP),ORCURRNT D  ;new mvt - autoDC
    44         . I $D(^ORE(100.2,"ADT",DGPMDA)) D  Q:$G(DONE)  ;ReEntered
    45         .. N LAST,OREVT S DONE=0
    46         .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0))
    47         .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0))  ;diff pat -> diff mvt
    48         .. S ORACT="RE",DONE=1 Q:OREVENT  ;log on new event instead
    49         .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1)
    50         . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out
    51         . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U))
    52         . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt
    53 C       ;
    54         I OREVENT D  ;release delayed orders, complete event
    55         . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA)
    56         . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use
    57         . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1)
    58         . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA
    59         . ;D UNLEVT^ORX2(OREVENT)
    60         I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL)
    61         I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events
    62         I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case
    63 FINISHED         ; unlock and clean up JEH
    64         D:$G(OREVNTLK) UNLEVT^ORX2(OREVNTLK) K ^XTMP("OREVENT",DFN,DGPMDA) ;195
    65         Q
    66         ;
    67 CURRENT()       ; -- Returns 1 or 0, if DGPMDA is the latest movement
    68         N Y,LAST,LASTYPE,LASTDT S Y=0
    69         S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2)
    70         ; VAIP(14) = last physical movement for the admission
    71         I DGPMT=6 D  G CQ
    72         . N CA,IDT I LAST,LASTDT>+VAIP(3) Q  ;last physical mvt
    73         . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3)
    74         . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q  ;last TS mvt
    75         I DGPMT=3 D  ;get last mvt overall
    76         . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT
    77         . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset
    78         I LAST=DGPMDA S Y=1 G CQ ;primary mvt
    79         I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt
    80 CQ      Q Y
    81         ;
    82 PREVTS()        ; -- Returns previous treating specialty
    83         N TS,TSP,CA,ID,LAST,Y
    84         S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P"))
    85         I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt
    86         ; look for TS mvt since last phys mvt
    87         S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA
    88         S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6))
    89 PRVQ    Q Y
    90         ;
    91 TYPE(X) ; -- Return type of event from MAS code
    92         N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"")
    93         Q Y
    94         ;
    95 DIV(LOC)        ; -- Return Institution file #4 ptr for LOC
    96         N X0,Y S X0=$G(^SC(+LOC,0))
    97         S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2)))
    98         Q Y
    99         ;
    100 PATEVT()        ; -- Find match to new data in Patient Event file
    101         N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ
    102         S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0
    103         S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)=""
    104         I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH
    105         I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH
    106         I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154
    107         F  S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1  S IFN=+$O(^(EVT,0)) D  Q:Y
    108         . Q:$$LAPSED^OREVNTX(+IFN)  Q:$P($G(^ORE(100.2,IFN,1)),U,5)
    109         . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV
    110         . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q  ;Xaction type
    111         . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q  ;Mvt type
    112         . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS))  Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV"))
    113         . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD))  Q:ORWARD=ORLAST("WD")
    114         . S Y=+IFN ;ok
    115         I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible
    116 PTQ     Q Y
    117         ;
    118 DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL
    119         N MVTYPE,DIV,XFER,ORY,EXC,OBS
    120         S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt
    121         S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186
    122         S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1)
    123         I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc
    124         I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS
    125         S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge
    126         S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate
    127         I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ
    128         I MVTYPE=4 D  G DCQ ;ck Div and Loc multiples
    129         . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q
    130         . N OLD,INCL S INCL=0 ;ck incl loc's
    131         . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q
    132         . S:'INCL ORY=0
    133         I DGPMT=3,OBS D  ;readmitting from observation?
    134         . N TORY
    135         . S TORY=ORY
    136         . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule
    137         . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0
    138         . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186
    139         . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds
    140 DCQ     Q ORY
    141         ;
    142 READMIT()       ; -- Return 1 or 0, if patient is being readmitted
    143         N X,Y,DIR
    144         S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? "
    145         S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation."
    146         D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^"
    147         Q Y
    148         ;
    149 COMP(ORDG)      ; -- Complete orders on event [Keep until GMRA*4*15]
    150         N ORI,ORLIST,ORIFN,OREDT
    151         I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0
    152         D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U)
    153         F  S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0  S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT
    154         Q
    155         ;
    156 LOC(NODE)       ; -- Returns [new] patient location from NODE
    157         N X,Y S X=$P($G(NODE),U,6)
    158         I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0))
    159         S Y=+$G(^DIC(42,+X,44))_";SC("
    160         Q Y
    161         ;
    162 DISCH   ; -- Lapse/cancel outstanding events on discharge
    163         D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations
    164         Q
    165         ;
    166 XTMP    ; -- Save ORIFN to possibly reinstate on admission
    167         ;    Also uses ORVP, DGPMDA
    168         Q:'$G(DGPMDA)  Q:'$G(ORIFN)  Q:'$G(ORVP)
    169         N ORNOW S ORNOW=+$$NOW^XLFDT
    170         I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP)
    171         I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D
    172         . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1)
    173         . S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation"
    174         S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4))
    175         S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA
    176         Q
    177         ;
    178 REINST  ; -- Reinstate meds from observation
    179         I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q   ;DBIA 3598
    180         N ORIDT,ORLASTDC,X0,ORIFN,PSIFN
    181         S ORIDT=+$O(^DGPM("ATID3",+ORVP,0)) S:DGPMT=2 ORIDT=$O(^DGPM("ATID3",+ORVP,ORIDT)) Q:ORIDT<1  S ORLASTDC=+$O(^(ORIDT,0)) ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH
    182         Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC  S X0=$G(^(0))
    183         I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q  ;readmit after one hour 177
    184         S ORIFN=0 F  S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN))  Q:ORIFN<1  S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD)  ;DBIA 3598
    185         K ^XTMP("ORDCOBS-"_+ORVP)
    186         Q
    187         ;
    188         ; -- Moved code:
    189 EXP(ORDER,ORSTOP)       G EXP^ORMEVNT1
    190 ACTIVE(ORDER,ORSTRT)    G ACT^ORMEVNT1
    191 PURGE(ORDER)    G PUR^ORMEVNT1
     1ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04  09:21
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195**;Dec 17, 1997
     3 ;
     4EN1 ; -- tasked entry point
     5 Q:'$G(DFN)  Q:$D(DGPMPC)  Q:DGPMT=4!(DGPMT=5)  ;skip lodger mvts
     6 N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I
     7 S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO=""
     8 S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")=""
     9 F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)=""
     10 D ^%ZTLOAD ;D EN^ORYDGPM
     11 Q
     12 ;
     13EN ; -- main entry point
     14 S:$D(ZTQUEUED) ZTREQ="@"
     15 Q:'$G(DFN)  Q:$D(DGPMPC)  Q:DGPMT=4!(DGPMT=5)
     16 I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195
     17 I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 ;195 edits processed after new
     18 N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context
     19 N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT
     20 S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D  Q  ;deleted
     21 . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
     22 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0))
     23 . D ACTLOG^OREVNTX(OREVT,"DL")
     24A ;
     25 S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1))
     26 S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0)
     27 S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL)
     28 S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)=""
     29 S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y)
     30 S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW")
     31 I OREVENT=-1 D EN1 Q  ;195 Can't lock, retry
     32 I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D  Q:$G(DONE)  ;edited
     33 . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
     34 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0))
     35 . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement
     36 . I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q  ;no change
     37 . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1
     38B ;
     39 I '$G(DGPMP),ORCURRNT D  ;new mvt - autoDC
     40 . I $D(^ORE(100.2,"ADT",DGPMDA)) D  Q:$G(DONE)  ;ReEntered
     41 .. N LAST,OREVT S DONE=0
     42 .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0))
     43 .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0))  ;diff pat -> diff mvt
     44 .. S ORACT="RE",DONE=1 Q:OREVENT  ;log on new event instead
     45 .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1)
     46 . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out
     47 . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U))
     48 . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt
     49C ;
     50 I OREVENT D  ;release delayed orders, complete event
     51 . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA)
     52 . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use
     53 . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1)
     54 . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA
     55 . ;D UNLEVT^ORX2(OREVENT)
     56 I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL)
     57 I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events
     58 I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case
     59 D:$G(OREVENT) UNLEVT^ORX2(OREVENT) K ^XTMP("OREVENT",DFN,DGPMDA) ;195
     60 Q
     61 ;
     62CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement
     63 N Y,LAST,LASTYPE,LASTDT S Y=0
     64 S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2)
     65 ; VAIP(14) = last physical movement for the admission
     66 I DGPMT=6 D  G CQ
     67 . N CA,IDT I LAST,LASTDT>+VAIP(3) Q  ;last physical mvt
     68 . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3)
     69 . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q  ;last TS mvt
     70 I DGPMT=3 D  ;get last mvt overall
     71 . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT
     72 . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset
     73 I LAST=DGPMDA S Y=1 G CQ ;primary mvt
     74 I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt
     75CQ Q Y
     76 ;
     77PREVTS() ; -- Returns previous treating specialty
     78 N TS,TSP,CA,ID,LAST,Y
     79 S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P"))
     80 I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt
     81 ; look for TS mvt since last phys mvt
     82 S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA
     83 S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6))
     84PRVQ Q Y
     85 ;
     86TYPE(X) ; -- Return type of event from MAS code
     87 N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"")
     88 Q Y
     89 ;
     90DIV(LOC) ; -- Return Institution file #4 ptr for LOC
     91 N X0,Y S X0=$G(^SC(+LOC,0))
     92 S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2)))
     93 Q Y
     94 ;
     95PATEVT() ; -- Find match to new data in Patient Event file
     96 N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ
     97 S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0
     98 S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)=""
     99 I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH
     100 I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH
     101 I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154
     102 F  S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1  S IFN=+$O(^(EVT,0)) D  Q:Y
     103 . Q:$$LAPSED^OREVNTX(+IFN)  Q:$P($G(^ORE(100.2,IFN,1)),U,5)
     104 . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV
     105 . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q  ;Xaction type
     106 . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q  ;Mvt type
     107 . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS))  Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV"))
     108 . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD))  Q:ORWARD=ORLAST("WD")
     109 . S Y=+IFN ;ok
     110 I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible
     111PTQ Q Y
     112 ;
     113DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL
     114 N MVTYPE,DIV,XFER,ORY,EXC,OBS
     115 S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt
     116 S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186
     117 S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1)
     118 I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc
     119 I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS
     120 S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge
     121 S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate
     122 I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ
     123 I MVTYPE=4 D  G DCQ ;ck Div and Loc multiples
     124 . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q
     125 . N OLD,INCL S INCL=0 ;ck incl loc's
     126 . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q
     127 . S:'INCL ORY=0
     128 I DGPMT=3,OBS D  ;readmitting from observation?
     129 . N TORY
     130 . S TORY=ORY
     131 . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule
     132 . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0
     133 . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186
     134 . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds
     135DCQ Q ORY
     136 ;
     137READMIT() ; -- Return 1 or 0, if patient is being readmitted
     138 N X,Y,DIR
     139 S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? "
     140 S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation."
     141 D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^"
     142 Q Y
     143 ;
     144COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15]
     145 N ORI,ORLIST,ORIFN,OREDT
     146 I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0
     147 D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U)
     148 F  S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0  S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT
     149 Q
     150 ;
     151LOC(NODE) ; -- Returns [new] patient location from NODE
     152 N X,Y S X=$P($G(NODE),U,6)
     153 I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0))
     154 S Y=+$G(^DIC(42,+X,44))_";SC("
     155 Q Y
     156 ;
     157DISCH ; -- Lapse/cancel outstanding events on discharge
     158 D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations
     159 Q
     160 ;
     161XTMP ; -- Save ORIFN to possibly reinstate on admission
     162 ;    Also uses ORVP, DGPMDA
     163 Q:'$G(DGPMDA)  Q:'$G(ORIFN)  Q:'$G(ORVP)
     164 N ORNOW S ORNOW=+$$NOW^XLFDT
     165 I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP)
     166 I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D
     167 . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1)
     168 . S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation"
     169 S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4))
     170 S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA
     171 Q
     172 ;
     173REINST ; -- Reinstate meds from observation
     174 I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q
     175 N ORIDT,ORLASTDC,X0,ORIFN,PSIFN
     176 S ORIDT=+$O(^DGPM("ATID3",+ORVP,0)) S:DGPMT=2 ORIDT=$O(^DGPM("ATID3",+ORVP,ORIDT)) Q:ORIDT<1  S ORLASTDC=+$O(^(ORIDT,0)) ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH
     177 Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC  S X0=$G(^(0))
     178 I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q  ;readmit after one hour 177
     179 S ORIFN=0 F  S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN))  Q:ORIFN<1  S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD)
     180 K ^XTMP("ORDCOBS-"_+ORVP)
     181 Q
     182 ;
     183 ; -- Moved code:
     184EXP(ORDER,ORSTOP) G EXP^ORMEVNT1
     185ACTIVE(ORDER,ORSTRT) G ACT^ORMEVNT1
     186PURGE(ORDER) G PUR^ORMEVNT1

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFH.m

    r613 r623  
    1 ORMFH   ;SLC/MKB - Process Dietetics ORM msgs ;5/5/05  13:18
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN      ; -- entry point for FH messages
    5         I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
    6         I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
    7         S ORLOG=+$E($$NOW^XLFDT,1,12) S:'$G(ORDUZ) ORDUZ=DUZ S:'$G(ORNP) ORNP=ORDUZ
    8         S:$G(DGPMT) ORNATR="A",OREASON=$S(DGPMT=1:"Admission",DGPMT=3:"Discharge",1:"Transfer"),ORDUZ=""
    9         D @ORDCNTRL
    10         Q
    11         ;
    12 ZP      ; -- Purged
    13         Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
    14         K ^OR(100,+ORIFN,4) I "^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
    15         Q
    16         ;
    17 ZR      ; -- Purged as requested [ack]
    18         D DELETE^ORCSAVE2(+ORIFN)
    19         Q
    20         ;
    21 ZU      ; -- Unable to purge [ack]
    22         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
    23         Q
    24         ;
    25 OK      ; -- Order accepted, FH order # assigned [ack]
    26         N ORSTS S ^OR(100,+ORIFN,4)=PKGIFN ; FH identifier
    27         I "DN"'[$E(PKGIFN) S ORSTS=6 ;not Diet or NPO
    28         E  S ORSTS=$S($P($G(^OR(100,+ORIFN,0)),U,8)>ORLOG:8,1:6)
    29         D STATUS^ORCSAVE2(+ORIFN,ORSTS)
    30         Q
    31         ;
    32 XX      ; -- Edited backdoor order (OP recurring meals only)
    33         D XX^ORMFH1 Q
    34         ;
    35 SN      ; -- New backdoor order: return NA msg w/ORIFN
    36         N ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL
    37         ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q
    38         ; Don't require provider until Nature of Order is added
    39         I '$G(DGPMT),'$D(^VA(200,+ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
    40         I 'ORSTRT S ORERR="Missing effective date/time" Q
    41         ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q
    42         D EN1^FHWOR8(ORL,.ORPARAM)
    43         S ODS=$O(@ORMSG@(+ORC)) I 'ODS S ORERR="Incomplete message" Q
    44         S ODS=ODS_U_@ORMSG@(ODS),ORSTS=6 I '$L(ORNATR),ORCAT="I" S ORNATR="S"
    45         I $E($P(ODS,U,2),1,3)="OBR" S OBR=ODS D IP G SN1
    46         I $E($P(ODS,U,2),1,3)="ODT" S ODT=ODS D TRAY G SN1
    47         I $E($P(ODS,U,2),1,3)'="ODS" S ORERR="Missing or invalid ODS segment" Q
    48         I $P(ODS,"|",2)="ZE" D TF G SN1
    49         I $P(ODS,"|",4)?1"^^^FH-6".E D ADDL G SN1
    50         I ORCAT'="I" D OPM^ORMFH1 G SN1
    51         I $P(ODS,"|",4)?1"^^^FH-5".E D NPO G SN1
    52 DIET    ; Diet order
    53         S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)),ORTRAIL="Diet"
    54         D GETDLG1^ORCD(ORDIALOG) S:ORSTRT>ORLOG ORSTS=8
    55         S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
    56         S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
    57         S X=$P(ODS,"|",2),ORDIALOG($$PTR("DELIVERY"),1)=$S($L(X)=1:X,1:$E(X,2))
    58         ; Comments ??
    59         S X=$$ORDITEM^ORM($P(ODS,"|",4))
    60         I 'X S ORERR="Missing or invalid diet modification" Q
    61         S I=1,OI=$$PTR("ORDERABLE ITEM"),ORDIALOG(OI,I)=X
    62         I $O(@ORMSG@(+ODS)) F  S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0  S SEG=$E(@ORMSG@(+ODS),1,3) Q:SEG="ORC"  Q:SEG="MSH"  I SEG="ODS" D  Q:$D(ORERR)
    63         . S X=$$ORDITEM^ORM($P(@ORMSG@(+ODS),"|",4))
    64         . I 'X S ORERR="Missing or invalid diet modification" Q
    65         . S I=I+1,ORDIALOG(OI,I)=X
    66 SN1     ; continue ... save order, post message
    67         Q:$D(ORERR)
    68         D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" Q
    69         D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
    70         D:'$P($G(^OR(100,ORIFN,0)),U,8) DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
    71         D STATUS^ORCSAVE2(ORIFN,ORSTS)
    72         I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
    73         S ^OR(100,ORIFN,4)=PKGIFN
    74         Q
    75         ;
    76 TRAY    ; Early/Late tray
    77         I 'ORSTOP S ORERR="Missing stop date" Q
    78         S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) D GETDLG1^ORCD(ORDIALOG),EN2^ORCDFH
    79         S ORDIALOG($$PTR("START DATE"),1)=ORSTRT
    80         S ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP
    81         N DAYS,SCH S DAYS="",SCH=$P(ORQT,U,2)
    82         I $L(SCH),SCH'="ONCE" F I=1:1:$L(SCH,"~") S X=+$P($P(SCH,"~",I),"J",2),DAYS=DAYS_$E("MTWRFSX",X)
    83         S:$L(DAYS) ORDIALOG($$PTR("SCHEDULE"),1)=DAYS
    84         S OI=+$O(^ORD(101.43,"S.E/L T",$P(ODT,"|",2)_" TRAY",0)),ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
    85         S X=$P($P(ODT,"|",3),U,4),ORDIALOG($$PTR("MEAL"),1)=$E(X)
    86         S ORDIALOG($$PTR("MEAL TIME"),1)=$P($G(ORTIME(OI,$E(X),+$E(X,3))),U,2)
    87         S:$L($P(ODT,"|",4)) ORDIALOG($$PTR("YES/NO"),1)=1
    88         Q
    89         ;
    90 IP      ; Isolation/Precautions
    91         N IP S IP=+$P($P(OBR,"|",13),U,4)
    92         I IP'>0 S ORERR="Missing or invalid isolation type" Q
    93         S ORDIALOG=$O(^ORD(101.41,"AB","FHW3",0)) D GETDLG1^ORCD(ORDIALOG)
    94         S ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP
    95         S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0))
    96         Q
    97         ;
    98 TF      ; Tubefeeding
    99         N OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR
    100         S ORDIALOG=$O(^ORD(101.41,"AB","FHW8",0)) D GETDLG1^ORCD(ORDIALOG)
    101         S OI=$$PTR("ORDERABLE ITEM"),STR=$$PTR("STRENGTH FH")
    102         S INSTR=$$PTR("INSTRUCTIONS"),CMMT=$$PTR("FREE TEXT 1")
    103         ; Comments ??
    104         S I=0 F  D  S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0  Q:$E(@ORMSG@(ODS),1,3)="ORC"  S ODS=ODS_U_@ORMSG@(ODS)
    105         . Q:$E($P(ODS,U,2),1,3)'="ODS"  ; not ODS segment
    106         . S X=$P(ODS,"|",4),X4=$P(X,U,4) ; OI
    107         . S:X4["-" $P(X,U,4)=+X4,X4=+$P(X4,"-",2) ; strength
    108         . S XI=$$ORDITEM^ORM(X) I 'XI S ORERR="Missing or invalid tubefeeding product" Q
    109         . S ZQT=$O(@ORMSG@(+ODS)) I 'ZQT S ORERR="Missing QT information" Q
    110         . S QT=$P(@ORMSG@(ZQT),"|",3),DUR=$P(QT,U,3)
    111         . S QTY=+QT_" "_$$UNITS($P($P(QT,U),"&",2))_"/"_$P(QT,U,2)
    112         . S:$L(DUR) QTY=QTY_" X "_+$E(DUR,2,99)_$S($E(DUR)="H":"HR",1:"")
    113         . S I=I+1,ORDIALOG(OI,I)=XI,ORDIALOG(STR,I)=X4,ORDIALOG(INSTR,I)=QTY
    114         . S:$L($P(ODS,"|",5)) ORDIALOG(CMMT,I)=$P(ODS,"|",5)
    115         I ORCAT="O",ORQT["~" D DATES
    116         Q
    117         ;
    118 UNITS(X)        ; -- Returns name of unit X
    119         N Y S X=$E(X)
    120         S Y=$S(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"")
    121         Q Y
    122         ;
    123 NPO     ; NPO <uses FHW1 dialog - FHW4 now a quick order>
    124         S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)) D GETDLG1^ORCD(ORDIALOG)
    125         S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.DIET","NPO",0))
    126         S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT S:ORSTRT>ORLOG ORSTS=8
    127         S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
    128         S:$L($P(ODS,"|",5)) ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5)
    129         Q
    130         ;
    131 ADDL    ; Additional order
    132         S ORDIALOG=$O(^ORD(101.41,"AB","FHW7",0)) D GETDLG1^ORCD(ORDIALOG)
    133         S ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5)
    134         I ORCAT="O",ORQT["~" D DATES
    135         Q
    136         ;
    137 DATES   ; -- pull dates out of ORQT
    138         N P,I,X S P=$$PTR("DATE/TIME")
    139         F I=1:1:$L(ORQT,"~") S X=$P(ORQT,"~",I),ORDIALOG(P,I)=$$HL7TFM^XLFDT($P(X,U,4))
    140         S ORSTRT=$G(ORDIALOG(P,1)),ORSTOP=$G(ORDIALOG(P,I))
    141         Q
    142         ;
    143 SC      ; -- Status Change
    144 SR      ; -- Status Update [ack]
    145         N ORSTS,OROLD S OROLD=$P($G(^OR(100,+ORIFN,3)),U,3)
    146         D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    147         S ORSTS=$S(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"")
    148         D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
    149         I ORDSTS="DC",'$D(^OR(100,+ORIFN,6)) D  ;set 6-node
    150         . I ORNATR'="A","DN"[$E(PKGIFN) S ORNATR="C" S:'$L(OREASON) OREASON="Replaced with new diet order" S:ORDUZ<1 ORDUZ=""
    151         . S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
    152         I OROLD=1,ORSTS=6 D  ; reactivate
    153         . N X S $P(^OR(100,+ORIFN,3),U,7)=1,X=$P(^(0),U,9) K ^(6)
    154         . I 'ORSTOP,X S $P(^OR(100,+ORIFN,0),U,9)="" K ^OR(100,"AE",X,+ORIFN)
    155         . D SETALL^ORDD100(+ORIFN)
    156         Q
    157         ;
    158 OC      ; -- Cancelled <E/L Trays only> / [ack]
    159         G:ORTYPE="ORR" UA ;rejected new order
    160         I $P($G(^OR(100,+ORIFN,3)),U,3)=6,$P(^(0),U,8)<ORLOG G OD
    161         S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
    162         D UPDATE(13,"DC")
    163         Q
    164         ;
    165 CR      ; -- Cancelled as requested [ack]
    166         D STATUS^ORCSAVE2(+ORIFN,13)
    167         Q
    168         ;
    169 OD      ; -- Discontinued <Tubefeedings only>
    170         S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
    171         D UPDATE(1,"DC")
    172         Q
    173         ;
    174 DR      ; -- Discontinued as requested [ack]
    175         D STATUS^ORCSAVE2(+ORIFN,1)
    176         Q
    177         ;
    178 UA      ; -- Unable to Accept [ack]
    179         S:'$L(ORNATR) ORNATR="X" ;Rejected
    180         S ^OR(100,+ORIFN,6)=+$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
    181         D STATUS^ORCSAVE2(+ORIFN,13)
    182 UC      ; -- Unable to Cancel [ack]
    183 UD      ; -- Unable to Discontinue [ack]
    184         N DA S DA=$P(ORIFN,";",2) I DA D
    185         . S:$G(OREJECT) $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ; request rejected
    186         . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
    187         Q
    188         ;
    189 UPDATE(ORSTS,ORACT)     ; -- continue processing
    190         N ORX,DA,ORP D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    191         D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
    192         S ORX=$$CREATE^ORX1(ORNATR) D:ORX
    193         . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
    194         . I DA'>0 S ORERR="Cannot create new order action" Q
    195         . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
    196         . D SIGSTS^ORCSAVE2(+ORIFN,DA)
    197         . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    198         . S $P(^OR(100,+ORIFN,3),U,7)=DA
    199         I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
    200         D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
    201         Q
    202         ;
    203 PTR(NAME)       ; -- Returns ien of prompt NAME in Order Dialog file #101.41
    204         Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     1ORMFH ;SLC/MKB - Process Dietetics ORM msgs ;5/5/05  13:18
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215**;Dec 17, 1997
     3 ;
     4EN ; -- entry point for FH messages
     5 I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
     6 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
     7 S ORLOG=+$E($$NOW^XLFDT,1,12) S:'$G(ORDUZ) ORDUZ=DUZ S:'$G(ORNP) ORNP=ORDUZ
     8 S:$G(DGPMT) ORNATR="A",OREASON=$S(DGPMT=1:"Admission",DGPMT=3:"Discharge",1:"Transfer"),ORDUZ=""
     9 D @ORDCNTRL
     10 Q
     11 ;
     12ZP ; -- Purged
     13 Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
     14 K ^OR(100,+ORIFN,4) I "^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
     15 Q
     16 ;
     17ZR ; -- Purged as requested [ack]
     18 D DELETE^ORCSAVE2(+ORIFN)
     19 Q
     20 ;
     21ZU ; -- Unable to purge [ack]
     22 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
     23 Q
     24 ;
     25OK ; -- Order accepted, FH order # assigned [ack]
     26 N ORSTS S ^OR(100,+ORIFN,4)=PKGIFN ; FH identifier
     27 I "DN"'[$E(PKGIFN) S ORSTS=6 ;not Diet or NPO
     28 E  S ORSTS=$S($P($G(^OR(100,+ORIFN,0)),U,8)>ORLOG:8,1:6)
     29 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
     30 Q
     31 ;
     32XX ; -- Edited backdoor order (OP recurring meals only)
     33 D XX^ORMFH1 Q
     34 ;
     35SN ; -- New backdoor order: return NA msg w/ORIFN
     36 N ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL
     37 ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q
     38 ; Don't require provider until Nature of Order is added
     39 I '$G(DGPMT),'$D(^VA(200,+ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
     40 I 'ORSTRT S ORERR="Missing effective date/time" Q
     41 ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q
     42 D EN1^FHWOR8(ORL,.ORPARAM)
     43 S ODS=$O(@ORMSG@(+ORC)) I 'ODS S ORERR="Incomplete message" Q
     44 S ODS=ODS_U_@ORMSG@(ODS),ORSTS=6 I '$L(ORNATR),ORCAT="I" S ORNATR="S"
     45 I $E($P(ODS,U,2),1,3)="OBR" S OBR=ODS D IP G SN1
     46 I $E($P(ODS,U,2),1,3)="ODT" S ODT=ODS D TRAY G SN1
     47 I $E($P(ODS,U,2),1,3)'="ODS" S ORERR="Missing or invalid ODS segment" Q
     48 I $P(ODS,"|",2)="ZE" D TF G SN1
     49 I $P(ODS,"|",4)?1"^^^FH-6".E D ADDL G SN1
     50 I ORCAT'="I" D OPM^ORMFH1 G SN1
     51 I $P(ODS,"|",4)?1"^^^FH-5".E D NPO G SN1
     52DIET ; Diet order
     53 S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)),ORTRAIL="Diet"
     54 D GETDLG1^ORCD(ORDIALOG) S:ORSTRT>ORLOG ORSTS=8
     55 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
     56 S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
     57 S X=$P(ODS,"|",2),ORDIALOG($$PTR("DELIVERY"),1)=$S($L(X)=1:X,1:$E(X,2))
     58 ; Comments ??
     59 S X=$$ORDITEM^ORM($P(ODS,"|",4))
     60 I 'X S ORERR="Missing or invalid diet modification" Q
     61 S I=1,OI=$$PTR("ORDERABLE ITEM"),ORDIALOG(OI,I)=X
     62 I $O(@ORMSG@(+ODS)) F  S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0  S SEG=$E(@ORMSG@(+ODS),1,3) Q:SEG="ORC"  Q:SEG="MSH"  I SEG="ODS" D  Q:$D(ORERR)
     63 . S X=$$ORDITEM^ORM($P(@ORMSG@(+ODS),"|",4))
     64 . I 'X S ORERR="Missing or invalid diet modification" Q
     65 . S I=I+1,ORDIALOG(OI,I)=X
     66SN1 ; continue ... save order, post message
     67 Q:$D(ORERR)
     68 D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" Q
     69 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
     70 D:'$P($G(^OR(100,ORIFN,0)),U,8) DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
     71 D STATUS^ORCSAVE2(ORIFN,ORSTS)
     72 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
     73 S ^OR(100,ORIFN,4)=PKGIFN
     74 Q
     75 ;
     76TRAY ; Early/Late tray
     77 I 'ORSTOP S ORERR="Missing stop date" Q
     78 S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) D GETDLG1^ORCD(ORDIALOG),EN2^ORCDFH
     79 S ORDIALOG($$PTR("START DATE"),1)=ORSTRT
     80 S ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP
     81 N DAYS,SCH S DAYS="",SCH=$P(ORQT,U,2)
     82 I $L(SCH),SCH'="ONCE" F I=1:1:$L(SCH,"~") S X=+$P($P(SCH,"~",I),"J",2),DAYS=DAYS_$E("MTWRFSX",X)
     83 S:$L(DAYS) ORDIALOG($$PTR("SCHEDULE"),1)=DAYS
     84 S OI=+$O(^ORD(101.43,"S.E/L T",$P(ODT,"|",2)_" TRAY",0)),ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
     85 S X=$P($P(ODT,"|",3),U,4),ORDIALOG($$PTR("MEAL"),1)=$E(X)
     86 S ORDIALOG($$PTR("MEAL TIME"),1)=$P($G(ORTIME(OI,$E(X),+$E(X,3))),U,2)
     87 S:$L($P(ODT,"|",4)) ORDIALOG($$PTR("YES/NO"),1)=1
     88 Q
     89 ;
     90IP ; Isolation/Precautions
     91 N IP S IP=+$P($P(OBR,"|",13),U,4)
     92 I IP'>0 S ORERR="Missing or invalid isolation type" Q
     93 S ORDIALOG=$O(^ORD(101.41,"AB","FHW3",0)) D GETDLG1^ORCD(ORDIALOG)
     94 S ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP
     95 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0))
     96 Q
     97 ;
     98TF ; Tubefeeding
     99 N OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR
     100 S ORDIALOG=$O(^ORD(101.41,"AB","FHW8",0)) D GETDLG1^ORCD(ORDIALOG)
     101 S OI=$$PTR("ORDERABLE ITEM"),STR=$$PTR("STRENGTH FH")
     102 S INSTR=$$PTR("INSTRUCTIONS"),CMMT=$$PTR("FREE TEXT 1")
     103 ; Comments ??
     104 S I=0 F  D  S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0  Q:$E(@ORMSG@(ODS),1,3)="ORC"  S ODS=ODS_U_@ORMSG@(ODS)
     105 . Q:$E($P(ODS,U,2),1,3)'="ODS"  ; not ODS segment
     106 . S X=$P(ODS,"|",4),X4=$P(X,U,4) ; OI
     107 . S:X4["-" $P(X,U,4)=+X4,X4=+$P(X4,"-",2) ; strength
     108 . S XI=$$ORDITEM^ORM(X) I 'XI S ORERR="Missing or invalid tubefeeding product" Q
     109 . S ZQT=$O(@ORMSG@(+ODS)) I 'ZQT S ORERR="Missing QT information" Q
     110 . S QT=$P(@ORMSG@(ZQT),"|",3),DUR=$P(QT,U,3)
     111 . S QTY=+QT_" "_$$UNITS($P($P(QT,U),"&",2))_"/"_$P(QT,U,2)
     112 . S:$L(DUR) QTY=QTY_" X "_+$E(DUR,2,99)_$S($E(DUR)="H":"HR",1:"")
     113 . S I=I+1,ORDIALOG(OI,I)=XI,ORDIALOG(STR,I)=X4,ORDIALOG(INSTR,I)=QTY
     114 . S:$L($P(ODS,"|",5)) ORDIALOG(CMMT,I)=$P(ODS,"|",5)
     115 I ORCAT="O",ORQT["~" D DATES
     116 Q
     117 ;
     118UNITS(X) ; -- Returns name of unit X
     119 N Y S X=$E(X)
     120 S Y=$S(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"")
     121 Q Y
     122 ;
     123NPO ; NPO <uses FHW1 dialog - FHW4 now a quick order>
     124 S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)) D GETDLG1^ORCD(ORDIALOG)
     125 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.DIET","NPO",0))
     126 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT S:ORSTRT>ORLOG ORSTS=8
     127 S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
     128 S:$L($P(ODS,"|",5)) ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5)
     129 Q
     130 ;
     131ADDL ; Additional order
     132 S ORDIALOG=$O(^ORD(101.41,"AB","FHW7",0)) D GETDLG1^ORCD(ORDIALOG)
     133 S ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5)
     134 I ORCAT="O",ORQT["~" D DATES
     135 Q
     136 ;
     137DATES ; -- pull dates out of ORQT
     138 N P,I,X S P=$$PTR("DATE/TIME")
     139 F I=1:1:$L(ORQT,"~") S X=$P(ORQT,"~",I),ORDIALOG(P,I)=$$HL7TFM^XLFDT($P(X,U,4))
     140 S ORSTRT=$G(ORDIALOG(P,1)),ORSTOP=$G(ORDIALOG(P,I))
     141 Q
     142 ;
     143SC ; -- Status Change
     144SR ; -- Status Update [ack]
     145 N ORSTS,OROLD S OROLD=$P($G(^OR(100,+ORIFN,3)),U,3)
     146 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     147 S ORSTS=$S(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"")
     148 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
     149 I ORDSTS="DC",'$D(^OR(100,+ORIFN,6)) D  ;set 6-node
     150 . I ORNATR'="A","DN"[$E(PKGIFN) S ORNATR="C" S:'$L(OREASON) OREASON="Replaced with new diet order" S:ORDUZ<1 ORDUZ=""
     151 . S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
     152 I OROLD=1,ORSTS=6 D  ; reactivate
     153 . N X S $P(^OR(100,+ORIFN,3),U,7)=1,X=$P(^(0),U,9) K ^(6)
     154 . I 'ORSTOP,X S $P(^OR(100,+ORIFN,0),U,9)="" K ^OR(100,"AE",X,+ORIFN)
     155 . D SETALL^ORDD100(+ORIFN)
     156 Q
     157 ;
     158OC ; -- Cancelled <E/L Trays only> / [ack]
     159 G:ORTYPE="ORR" UA ;rejected new order
     160 I $P($G(^OR(100,+ORIFN,3)),U,3)=6,$P(^(0),U,8)<ORLOG G OD
     161 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
     162 D UPDATE(13,"DC")
     163 Q
     164 ;
     165CR ; -- Cancelled as requested [ack]
     166 D STATUS^ORCSAVE2(+ORIFN,13)
     167 Q
     168 ;
     169OD ; -- Discontinued <Tubefeedings only>
     170 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
     171 D UPDATE(1,"DC")
     172 Q
     173 ;
     174DR ; -- Discontinued as requested [ack]
     175 D STATUS^ORCSAVE2(+ORIFN,1)
     176 Q
     177 ;
     178UA ; -- Unable to Accept [ack]
     179 S:'$L(ORNATR) ORNATR="X" ;Rejected
     180 S ^OR(100,+ORIFN,6)=+$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
     181 D STATUS^ORCSAVE2(+ORIFN,13)
     182UC ; -- Unable to Cancel [ack]
     183UD ; -- Unable to Discontinue [ack]
     184 N DA S DA=$P(ORIFN,";",2) I DA D
     185 . S:$G(OREJECT) $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ; request rejected
     186 . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
     187 Q
     188 ;
     189UPDATE(ORSTS,ORACT) ; -- continue processing
     190 N ORX,DA,ORP D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     191 D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
     192 S ORX=$$CREATE^ORX1(ORNATR) D:ORX
     193 . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
     194 . I DA'>0 S ORERR="Cannot create new order action" Q
     195 . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
     196 . D SIGSTS^ORCSAVE2(+ORIFN,DA)
     197 . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     198 . S $P(^OR(100,+ORIFN,3),U,7)=DA
     199 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
     200 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
     201 Q
     202 ;
     203PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
     204 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFN.m

    r613 r623  
    1 ORMFN   ; SLC/MKB - MFN msg router ;11/21/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215,243**;Dec 17, 1997;Build 242
    3 EN(MSG) ; -- main entry point for OR ITEM RECEIVE
    4         N ORMSG,ORNMSP,ORDG,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO
    5         S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0))  ; msg array root
    6         N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG
    7 MSH     S MSH=0 F  S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0  Q:$E(@ORMSG@(MSH),1,3)="MSH"
    8         Q:'MSH  S MSH=MSH_U_@ORMSG@(MSH)
    9         S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING"
    10         S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP)
    11         S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI"  ; error
    12 MFE     S MFE=+MFI ; ** loop through each MFE segment
    13         F  S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0  I $E(@ORMSG@(MFE),1,3)="MFE" D
    14         . K ORFLD,ORFDA
    15         . S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4)
    16         . S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ")
    17         . S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6)
    18         . S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_","
    19         . S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate)
    20         . Q:'ORACTION  ; 0=error
    21         . I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q
    22 ADD     . I ORACTION=1,'ORDIFN D  Q:'ORDIFN  ;create item if it doesn't exist
    23         . . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_","
    24         . . S ORFDA(101.43,ORFIEN,5)=+ORDG
    25         . S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U)
    26         . S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS)
    27         . S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"")
    28         . F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA")
    29 ZPKG    . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE))
    30         . I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment
    31         . D FILE^DIE("K","ORFDA") ; file data
    32 ZLC     . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D
    33         . . N COMP,CID,CODE,CSYS
    34         . . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2)
    35         . . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST
    36         . . F  S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0  Q:$E(@ORMSG@(ZLC),1,3)'="ZLC"  D
    37         . . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q
    38         . . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD
    39         . . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99)
    40         . . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS"
    41         . . . D FILE^DICN S LAST=ZLC
    42 ZSY     . I $D(^ORD(101.43,ORDIFN,2)) D  ; kill old ones first
    43         . . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2,"
    44         . . S DA=0 F  S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0  D ^DIK
    45         . . K ^ORD(101.43,ORDIFN,2),DIK,DA
    46         . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D
    47         . . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2,"
    48         . . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2)
    49         . . F  S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0  Q:$E(@ORMSG@(ZSY),1,3)'="ZSY"  D
    50         . . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY
    51         . . . K DD,DO D:$L(X) FILE^DICN
    52 NTE     . K ^ORD(101.43,ORDIFN,8) ; replace text
    53         . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D
    54         . . S NTE=LAST,DA=0
    55         . . F  S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0  Q:$E(@ORMSG@(NTE),1,3)'="NTE"  S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D
    56         . . . S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I)
    57         . . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U
    58         Q
    59         ;
    60 NMSP(NAME)      ; -- returns namespace for package
    61         I NAME="RADIOLOGY" Q "RA"
    62         I NAME="IMAGING" Q "RA"
    63         I NAME="LABORATORY" Q "LR"
    64         I NAME="DIETETICS" Q "FH"
    65         I NAME="PHARMACY" Q "PS"
    66         I NAME="CONSULTS" Q "CS"
    67         I NAME="PROCEDURES" Q "CS"
    68         Q ""
    69         ;
    70 CREATE(X)       ; -- Create new item in #101.43
    71         Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I
    72         L +^ORD(101.43,0):1 Q:'$T 0
    73         S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0
    74         S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
    75         F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0))
    76         S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)=""
    77         S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1)
    78         L -^ORD(101.43,0)
    79         Q I
    80         ;
    81 FH      ; -- Dietetics
    82         S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X)
    83         S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X)
    84         S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X)
    85         F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
    86         K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4)
    87         I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X
    88         Q
    89         ;
    90 LR      ; -- Laboratory
    91         S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X)
    92         S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X)
    93         ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X)
    94         S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X)
    95         S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X)
    96         S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X)
    97         S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X)
    98         S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X)
    99         F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
    100         Q
    101         ;
    102 PS      ; -- Pharmacy
    103         N ROUTE
    104         S X=$P(ZPKG,"|",2)
    105         ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1)
    106         S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med
    107         S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med
    108         S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln
    109         S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive
    110         S ORFDA(101.43,ORFIEN,50.5)=(X["S") ;supply item
    111         S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med
    112         S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0)
    113         ;Check for default med route
    114         ;S ROUTE=$$MEDROUTE
    115         ;I ROUTE>0 S ORFDA(101.43,ORFIEN,50.8)=ROUTE
    116         Q
    117         ;
    118 MEDROUTE()      ;
    119         N CNT,ROUTE
    120         S CNT=0,ROUTE=0
    121         F  S CNT=$O(@ORMSG@(CNT)) Q:CNT'>0  D
    122         .I $P($G(@ORMSG@(CNT)),"|")'="ZPB" Q
    123         .S ROUTE=+$P($G(@ORMSG@(CNT)),"|",4)
    124         Q ROUTE
    125         ;
    126 RA      ; -- Radiology/Nuc Medicine
    127         S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X)
    128         S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X)
    129         S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X)
    130         S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X)
    131         S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0)
    132         S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1)
    133         F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
    134         Q
    135         ;
    136 CS      ; -- Consults/Requests
    137         S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X)
    138         D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA")
    139         Q
     1ORMFN ; SLC/MKB - MFN msg router ;04:29 PM  19 Dec 2000
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215**;Dec 17, 1997
     3EN(MSG) ; -- main entry point for OR ITEM RECEIVE
     4 N ORMSG,ORNMSP,ORDG,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO
     5 S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0))  ; msg array root
     6 N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG
     7MSH S MSH=0 F  S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0  Q:$E(@ORMSG@(MSH),1,3)="MSH"
     8 Q:'MSH  S MSH=MSH_U_@ORMSG@(MSH)
     9 S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING"
     10 S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP)
     11 S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI"  ; error
     12MFE S MFE=+MFI ; ** loop through each MFE segment
     13 F  S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0  I $E(@ORMSG@(MFE),1,3)="MFE" D
     14 . K ORFLD,ORFDA
     15 . S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4)
     16 . S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ")
     17 . S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6)
     18 . S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_","
     19 . S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate)
     20 . Q:'ORACTION  ; 0=error
     21 . I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q
     22ADD . I ORACTION=1,'ORDIFN D  Q:'ORDIFN  ;create item if it doesn't exist
     23 . . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_","
     24 . . S ORFDA(101.43,ORFIEN,5)=+ORDG
     25 . S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U)
     26 . S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS)
     27 . S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"")
     28 . F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA")
     29ZPKG . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE))
     30 . I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment
     31 . D FILE^DIE("K","ORFDA") ; file data
     32ZLC . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D
     33 . . N COMP,CID,CODE,CSYS
     34 . . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2)
     35 . . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST
     36 . . F  S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0  Q:$E(@ORMSG@(ZLC),1,3)'="ZLC"  D
     37 . . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q
     38 . . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD
     39 . . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99)
     40 . . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS"
     41 . . . D FILE^DICN S LAST=ZLC
     42ZSY . I $D(^ORD(101.43,ORDIFN,2)) D  ; kill old ones first
     43 . . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2,"
     44 . . S DA=0 F  S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0  D ^DIK
     45 . . K ^ORD(101.43,ORDIFN,2),DIK,DA
     46 . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D
     47 . . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2,"
     48 . . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2)
     49 . . F  S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0  Q:$E(@ORMSG@(ZSY),1,3)'="ZSY"  D
     50 . . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY
     51 . . . K DD,DO D:$L(X) FILE^DICN
     52NTE . K ^ORD(101.43,ORDIFN,8) ; replace text
     53 . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D
     54 . . S NTE=LAST,DA=0
     55 . . F  S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0  Q:$E(@ORMSG@(NTE),1,3)'="NTE"  S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D
     56 . . . S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I)
     57 . . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U
     58 Q
     59 ;
     60NMSP(NAME) ; -- returns namespace for package
     61 I NAME="RADIOLOGY" Q "RA"
     62 I NAME="IMAGING" Q "RA"
     63 I NAME="LABORATORY" Q "LR"
     64 I NAME="DIETETICS" Q "FH"
     65 I NAME="PHARMACY" Q "PS"
     66 I NAME="CONSULTS" Q "CS"
     67 I NAME="PROCEDURES" Q "CS"
     68 Q ""
     69 ;
     70CREATE(X) ; -- Create new item in #101.43
     71 Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I
     72 L +^ORD(101.43,0):1 Q:'$T 0
     73 S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0
     74 S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
     75 F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0))
     76 S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)=""
     77 S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1)
     78 L -^ORD(101.43,0)
     79 Q I
     80 ;
     81FH ; -- Dietetics
     82 S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X)
     83 S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X)
     84 S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X)
     85 F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
     86 K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4)
     87 I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X
     88 Q
     89 ;
     90LR ; -- Laboratory
     91 S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X)
     92 S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X)
     93 ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X)
     94 S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X)
     95 S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X)
     96 S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X)
     97 S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X)
     98 S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X)
     99 F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
     100 Q
     101 ;
     102PS ; -- Pharmacy
     103 S X=$P(ZPKG,"|",2)
     104 ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1)
     105 S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med
     106 S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med
     107 S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln
     108 S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive
     109 S ORFDA(101.43,ORFIEN,50.5)=(X["S") ;supply item
     110 S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med
     111 S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0)
     112 Q
     113 ;
     114RA ; -- Radiology/Nuc Medicine
     115 S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X)
     116 S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X)
     117 S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X)
     118 S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X)
     119 S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0)
     120 S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1)
     121 F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA")
     122 Q
     123 ;
     124CS ; -- Consults/Requests
     125 S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X)
     126 D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA")
     127 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m

    r613 r623  
    1 ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;12/13/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243**;Dec 17, 1997;Build 242
    3 EN      ; -- entry point for GMRC messges
    4         I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
    5         I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
    6         S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code
    7         N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS)
    8         S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ=""
    9         S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1=""
    10         I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4)
    11         D @ORDCNTRL
    12         Q
    13         ;
    14 ZP      ; -- Purged
    15         Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
    16         K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
    17         Q
    18         ;
    19 ZR      ; -- Purged as requested [ack]
    20         D DELETE^ORCSAVE2(+ORIFN)
    21         Q
    22         ;
    23 ZU      ; -- Unable to purge [ack]
    24         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
    25         Q
    26         ;
    27 OK      ; -- Order accepted, GMRC order # assigned [ack]
    28         S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5
    29         D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending
    30         D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12))
    31         Q
    32         ;
    33 XX      ; -- Change order
    34         N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S"
    35         D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)  S ORIFN=+ORIFN
    36         S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
    37         I ORDA'>0 S ORERR="Cannot create new order action" Q
    38         ; -Update sts of order to active, last action to dc/edit:
    39         S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1)
    40         I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12
    41         S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
    42         D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
    43         D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
    44         ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
    45         S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
    46         D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
    47         ; -Update responses, get/save new order text:
    48         K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
    49         S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
    50         K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data
    51         D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
    52         I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    53         Q
    54         ;
    55 SN      ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
    56         N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
    57         I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
    58         I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
    59         I '$G(ORL) S ORERR="Missing or invalid patient location" Q
    60         D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)
    61 SN1     D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs
    62         I '$G(ORIFN) S ORERR="Cannot create new order" Q
    63         ;Save DG1 and ZCL segments of HL7 message from backdoor orders
    64         D BDOSTR^ORWDBA3
    65         D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
    66         S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT)
    67         D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
    68         I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
    69         S ^OR(100,ORIFN,4)=PKGIFN
    70         Q
    71         ;
    72 DLG     ; -- Build ORDIALOG(),ORDG from msg
    73         N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I
    74         S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
    75         S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST")
    76         S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
    77         D GETDLG1^ORCD(ORDIALOG)
    78         S ORDIALOG($$PTR("URGENCY"),1)=ORURG
    79         S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q
    80         S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
    81         S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D
    82         . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3)
    83         . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4)
    84         . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
    85 D1      S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
    86         S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J)
    87         S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20)
    88         S OBX=OBR F  S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0  S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC"  Q:J="MSH"  I J="OBX" D
    89         . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX)
    90         . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6)
    91         . I NAME="PROVISIONAL DIAGNOSIS" D  Q
    92         .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2)
    93         .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
    94         . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE
    95         . S J=0 F  S J=$O(@ORMSG@(OBX,J)) Q:J'>0  S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J)
    96         S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
    97         Q
    98         ;
    99 OBR()   ; -- Return subscript of RXE segment
    100         N X,I,SEG S X="",I=+ORC
    101         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="OBR" S X=I Q
    102         Q X
    103         ;
    104 SC      ; -- Status changed (i.e. scheduled)
    105         S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active
    106         Q
    107         ;
    108 STATUS(X)       ; -- Returns ptr to Order Status file #100.01
    109         Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
    110         ;
    111 RE      ; -- Completed, w/results
    112         N I,SEG,DA,DR,DIE,X,Y
    113         S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
    114         S X="",DA=+ORIFN,DIE="^OR(100,"
    115         S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE
    116         S I=+ORC,X="" F  S I=$O(@ORMSG@(I)) Q:I<1  S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC"  I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q
    117         S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"")
    118         S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
    119         I $P(ORC,"|",17)["MAINTENANCE" Q  ;group update - no CM ack needed
    120         I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
    121         Q
    122         ;
    123 UA      ; -- Unable to Accept [ack]
    124         S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON
    125 OC      ; -- Cancelled/Denied
    126         S:'$L(ORNATR) ORNATR="X" ;Rejected
    127         S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
    128         D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q
    129 UD      ; -- Unable to discontinue [ack]
    130         N DA S DA=$P(ORIFN,";",2) I DA D
    131         . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
    132         . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1
    133         Q
    134         ;
    135 OD      ; -- Discontinued
    136         S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
    137         D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR)
    138         Q
    139         ;
    140 DR      ; -- Discontinued [ack]
    141         D STATUS^ORCSAVE2(+ORIFN,1)
    142         Q
    143         ;
    144 UPDATE(ORACT)   ; -- continue processing
    145         N ORX,ORDA,ORP
    146         S ORX=$$CREATE^ORX1(ORNATR) D:ORX
    147         . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
    148         . I ORDA'>0 S ORERR="Cannot create new order action" Q
    149         . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
    150         . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
    151         . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    152         . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
    153         I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
    154         D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
    155         Q
    156         ;
    157 PTR(X)  ; -- Returns ptr to prompt in Order Dialog file #101.41
    158         Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
     1ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;7/14/04 13:29
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255**;Dec 17, 1997
     3EN ; -- entry point for GMRC messges
     4 I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
     5 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
     6 S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code
     7 N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS)
     8 S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ=""
     9 S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1=""
     10 I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4)
     11 D @ORDCNTRL
     12 Q
     13 ;
     14ZP ; -- Purged
     15 Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
     16 K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
     17 Q
     18 ;
     19ZR ; -- Purged as requested [ack]
     20 D DELETE^ORCSAVE2(+ORIFN)
     21 Q
     22 ;
     23ZU ; -- Unable to purge [ack]
     24 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
     25 Q
     26 ;
     27OK ; -- Order accepted, GMRC order # assigned [ack]
     28 S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5
     29 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending
     30 D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12))
     31 Q
     32 ;
     33XX ; -- Change order
     34 N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S"
     35 D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)  S ORIFN=+ORIFN
     36 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
     37 I ORDA'>0 S ORERR="Cannot create new order action" Q
     38 ; -Update sts of order to active, last action to dc/edit:
     39 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1)
     40 I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12
     41 S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
     42 D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG)  ; JEH 255
     43 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
     44 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
     45 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
     46 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
     47 ; -Update responses, get/save new order text:
     48 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
     49 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
     50 K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data
     51 D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG)  ; JEH 255
     52 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     53 Q
     54 ;
     55SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
     56 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
     57 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
     58 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
     59 I '$G(ORL) S ORERR="Missing or invalid patient location" Q
     60 D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)
     61SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs
     62 I '$G(ORIFN) S ORERR="Cannot create new order" Q
     63 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
     64 D BDOSTR^ORWDBA3
     65 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
     66 S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT)
     67 D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
     68 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
     69 S ^OR(100,ORIFN,4)=PKGIFN
     70 Q
     71 ;
     72DLG ; -- Build ORDIALOG(),ORDG from msg
     73 N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I
     74 S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
     75 S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST")
     76 S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
     77 D GETDLG1^ORCD(ORDIALOG)
     78 S ORDIALOG($$PTR("URGENCY"),1)=ORURG
     79 S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q
     80 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
     81 S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D
     82 . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3)
     83 . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4)
     84 . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
     85D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
     86 S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J)
     87 S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20)
     88 S OBX=OBR F  S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0  S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC"  Q:J="MSH"  I J="OBX" D
     89 . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX)
     90 . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6)
     91 . I NAME="PROVISIONAL DIAGNOSIS" D  Q
     92 .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2)
     93 .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
     94 . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE
     95 . S J=0 F  S J=$O(@ORMSG@(OBX,J)) Q:J'>0  S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J)
     96 S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
     97 Q
     98 ;
     99OBR() ; -- Return subscript of RXE segment
     100 N X,I,SEG S X="",I=+ORC
     101 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="OBR" S X=I Q
     102 Q X
     103 ;
     104SC ; -- Status changed (i.e. scheduled)
     105 S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active
     106 Q
     107 ;
     108STATUS(X) ; -- Returns ptr to Order Status file #100.01
     109 Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
     110 ;
     111RE ; -- Completed, w/results
     112 N I,SEG,DA,DR,DIE,X,Y
     113 S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
     114 S X="",DA=+ORIFN,DIE="^OR(100,"
     115 S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE
     116 S I=+ORC,X="" F  S I=$O(@ORMSG@(I)) Q:I<1  S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC"  I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q
     117 S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"")
     118 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
     119 I $P(ORC,"|",17)["MAINTENANCE" Q  ;group update - no CM ack needed
     120 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
     121 Q
     122 ;
     123UA ; -- Unable to Accept [ack]
     124 S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON
     125OC ; -- Cancelled/Denied
     126 S:'$L(ORNATR) ORNATR="X" ;Rejected
     127 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
     128 D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q
     129UD ; -- Unable to discontinue [ack]
     130 N DA S DA=$P(ORIFN,";",2) I DA D
     131 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
     132 . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1
     133 Q
     134 ;
     135OD ; -- Discontinued
     136 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
     137 D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR)
     138 Q
     139 ;
     140DR ; -- Discontinued [ack]
     141 D STATUS^ORCSAVE2(+ORIFN,1)
     142 Q
     143 ;
     144UPDATE(ORACT) ; -- continue processing
     145 N ORX,ORDA,ORP
     146 S ORX=$$CREATE^ORX1(ORNATR) D:ORX
     147 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
     148 . I ORDA'>0 S ORERR="Cannot create new order action" Q
     149 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
     150 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
     151 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     152 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
     153 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
     154 D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
     155 Q
     156 ;
     157PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
     158 Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMLR.m

    r613 r623  
    1 ORMLR   ; SLC/MKB - Process Lab ORM msgs ;11:59 AM  26 Jul 2000
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243**;Dec 17, 1997;Build 242
    3 EN      ; -- entry point for LR messages
    4         I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
    5         I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D  Q:$L($G(ORERR))
    6         . I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
    7         . S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
    8         S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7)
    9         D @ORDCNTRL
    10         Q
    11         ;
    12 STATUS(X)       ; -- Returns Order Status for HL7 code X
    13         N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"")
    14         Q Y
    15         ;
    16 OK      ; -- Order accepted, LR order # assigned [ack]
    17         S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier
    18         D STATUS^ORCSAVE2(+ORIFN,5) ; pending
    19         Q
    20         ;
    21 ZC      ; -- Convert existing 2.5 orders to 3.0 format
    22         S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D  Q  ;create
    23         . K ORIFN D SN Q:'$G(ORIFN)  S ORDCNTRL="SN"
    24         . I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP
    25         N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN
    26         S I=+ORC F  S I=$O(@ORMSG@(I)) Q:'I  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  Q:SEG="MSH"  I SEG="OBR" S OBR=I Q
    27         I '$G(OBR) S ORERR="Missing OBR segment" Q
    28         S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0))
    29         D GETDLG1^ORCD(ORDIALOG)
    30         S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q
    31         S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16)
    32         S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4)
    33         S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4))
    34         S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2)
    35         S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
    36 ZC1     S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D
    37         . N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J)
    38         . S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
    39         . S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I)
    40         . S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U
    41         . S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)"
    42         S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
    43         S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
    44         D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5)
    45         K ^TMP("ORWORD",$J)
    46         Q
    47         ;
    48 SN      ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
    49         N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP
    50         I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q
    51         ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
    52         ;S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB)
    53         S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB")
    54         S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG)
    55         S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
    56         S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J)
    57 SN1     S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
    58         S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q
    59         S LRSUB=$P(^ORD(101.43,OI,"LR"),U,6),ORDG=$$DGRP(LRSUB)
    60         S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
    61         I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2
    62         S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4)
    63         S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4))
    64         S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9)
    65         S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
    66 SN2     S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D
    67         . S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
    68         . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I)
    69         . S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)"
    70 SNQ     D EN^ORCSAVE K ^TMP("ORWORD",$J)
    71         I '$G(ORIFN) S ORERR="Cannot create new order" Q
    72         ;Save DG1 and ZCL segments of HL7 message from backdoor orders
    73         D BDOSTR^ORWDBA3
    74         D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
    75         D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself
    76         S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
    77         I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL)
    78         S ^OR(100,ORIFN,4)=PKGIFN
    79         Q
    80         ;
    81 PTR(NAME)       ; -- Returns ien of prompt NAME in Order Dialog file #101.41
    82         Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
    83         ;
    84 DGRP(DG)        ; -- Returns Display Group ptr based on Lab section
    85         N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0))
    86         S:'Y Y=$O(^ORD(100.98,"B","LAB",0))
    87         Q Y
    88         ;
    89 XX      ; -- Changed: NOT IN USE
    90         D XX^ORMLR1
    91         Q
    92         ;
    93 XR      ; -- Changed [ack]: NOT IN USE
    94         N ORIG
    95         S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5)
    96         D:ORIG STATUS^ORCSAVE2(ORIG,12)
    97         D STATUS^ORCSAVE2(+ORIFN,5) ; pending
    98         Q
    99         ;
    100 ZP      ; -- Purged
    101         Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
    102         S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active
    103         Q
    104         ;
    105 ZR      ; -- Purged as requested [ack]
    106         D DELETE^ORCSAVE2(+ORIFN)
    107         Q
    108         ;
    109 ZU      ; -- Unable to purge [ack]
    110         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
    111         Q
    112         ;
    113 SC      ; -- Status changed (collected)
    114         N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    115         S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
    116         S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2)
    117         Q
    118         ;
    119 RE      ; -- Completed, w/results
    120         N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB
    121         S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
    122         S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D  ;get Results D/T [from OBR]
    123         . N OBR S OBR=+$O(@ORMSG@(+ORC)),X=""
    124         . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
    125         . S X=$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12))
    126         . S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)=""
    127         D RR^LR7OR1(DFN,PKGIFN)
    128         S ORABN="",ORFIND=""
    129         I $D(^TMP("LRRR",$J)) D
    130         . N IDT,DNAM,ORSLT
    131         . S IDT=0 F  S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT  D
    132         .. S DNAM=0 F  S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM  D
    133         ... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM))
    134         ... I '$L($P(ORSLT,U,3)) Q
    135         ... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"")
    136         ... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2)
    137         . Q
    138         K ^TMP("LRRR",$J),^TMP("LRX",$J)
    139         S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND
    140         S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
    141         I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
    142         Q
    143         ;
    144 OC      ; -- Cancelled
    145         G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ=""
    146         S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80)
    147         D UPDATE(1,"DC")
    148         Q
    149         ;
    150 CR      ; -- Cancelled [ack]
    151         D STATUS^ORCSAVE2(+ORIFN,1)
    152         Q
    153         ;
    154 UA      ; -- Unable to accept [ack]
    155 UX      ; -- Unable to change [ack]: NOT IN USE
    156         S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected
    157         S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80)
    158         D STATUS^ORCSAVE2(+ORIFN,13)
    159 UC      ; -- Unable to cancel [ack]
    160 DE      ; -- Data Error [ack]
    161         N DA S DA=$P(ORIFN,";",2) Q:'DA
    162         S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
    163         S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240)
    164         Q
    165         ;
    166 UPDATE(ORSTS,ORACT)     ; -- continue processing
    167         N DA,ORX,ORCMMT,ORP
    168         D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    169         D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
    170         S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX
    171         . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ)
    172         . I DA'>0 S ORERR="Cannot create new order action" Q
    173         . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
    174         . D SIGSTS^ORCSAVE2(+ORIFN,DA)
    175         . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    176         . S $P(^OR(100,+ORIFN,3),U,7)=DA
    177         I '$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
    178         D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
    179         Q
    180         ;
    181 REASON()        ; -- Get reason from OREASON or NTE segments
    182         N NTE,CMMT,X,Y,I,L
    183         S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5)
    184         G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments
    185         S Y=$P(@ORMSG@(NTE),"|",4),I=0
    186         F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q
    187         S $P(CMMT,U,2)=Y
    188 RQ      Q CMMT
     1ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM  26 Jul 2000
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195**;Dec 17, 1997
     3EN ; -- entry point for LR messages
     4 I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
     5 I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D  Q:$L($G(ORERR))
     6 . I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
     7 . S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
     8 S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7)
     9 D @ORDCNTRL
     10 Q
     11 ;
     12STATUS(X) ; -- Returns Order Status for HL7 code X
     13 N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"")
     14 Q Y
     15 ;
     16OK ; -- Order accepted, LR order # assigned [ack]
     17 S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier
     18 D STATUS^ORCSAVE2(+ORIFN,5) ; pending
     19 Q
     20 ;
     21ZC ; -- Convert existing 2.5 orders to 3.0 format
     22 S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D  Q  ;create
     23 . K ORIFN D SN Q:'$G(ORIFN)  S ORDCNTRL="SN"
     24 . I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP
     25 N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN
     26 S I=+ORC F  S I=$O(@ORMSG@(I)) Q:'I  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  Q:SEG="MSH"  I SEG="OBR" S OBR=I Q
     27 I '$G(OBR) S ORERR="Missing OBR segment" Q
     28 S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0))
     29 D GETDLG1^ORCD(ORDIALOG)
     30 S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q
     31 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16)
     32 S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4)
     33 S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4))
     34 S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2)
     35 S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
     36ZC1 S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D
     37 . N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J)
     38 . S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
     39 . S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I)
     40 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U
     41 . S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)"
     42 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
     43 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
     44 D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5)
     45 K ^TMP("ORWORD",$J)
     46 Q
     47 ;
     48SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
     49 N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP
     50 I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q
     51 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
     52 S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB)
     53 S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB")
     54 S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG)
     55 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
     56 S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J)
     57SN1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
     58 S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q
     59 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
     60 I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2
     61 S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4)
     62 S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4))
     63 S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9)
     64 S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
     65SN2 S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D
     66 . S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
     67 . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I)
     68 . S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)"
     69SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J)
     70 I '$G(ORIFN) S ORERR="Cannot create new order" Q
     71 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
     72 D BDOSTR^ORWDBA3
     73 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
     74 D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself
     75 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
     76 I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL)
     77 S ^OR(100,ORIFN,4)=PKGIFN
     78 Q
     79 ;
     80PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
     81 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     82 ;
     83DGRP(DG) ; -- Returns Display Group ptr based on Lab section
     84 N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0))
     85 S:'Y Y=$O(^ORD(100.98,"B","LAB",0))
     86 Q Y
     87 ;
     88XX ; -- Changed: NOT IN USE
     89 D XX^ORMLR1
     90 Q
     91 ;
     92XR ; -- Changed [ack]: NOT IN USE
     93 N ORIG
     94 S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5)
     95 D:ORIG STATUS^ORCSAVE2(ORIG,12)
     96 D STATUS^ORCSAVE2(+ORIFN,5) ; pending
     97 Q
     98 ;
     99ZP ; -- Purged
     100 Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
     101 S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active
     102 Q
     103 ;
     104ZR ; -- Purged as requested [ack]
     105 D DELETE^ORCSAVE2(+ORIFN)
     106 Q
     107 ;
     108ZU ; -- Unable to purge [ack]
     109 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
     110 Q
     111 ;
     112SC ; -- Status changed (collected)
     113 N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     114 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
     115 S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2)
     116 Q
     117 ;
     118RE ; -- Completed, w/results
     119 N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB
     120 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
     121 S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D  ;get Results D/T [from OBR]
     122 . N OBR S OBR=+$O(@ORMSG@(+ORC)),X=""
     123 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
     124 . S X=$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12))
     125 . S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)=""
     126 D RR^LR7OR1(DFN,PKGIFN)
     127 S ORABN="",ORFIND=""
     128 I $D(^TMP("LRRR",$J)) D
     129 . N IDT,DNAM,ORSLT
     130 . S IDT=0 F  S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT  D
     131 .. S DNAM=0 F  S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM  D
     132 ... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM))
     133 ... I '$L($P(ORSLT,U,3)) Q
     134 ... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"")
     135 ... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2)
     136 . Q
     137 K ^TMP("LRRR",$J),^TMP("LRX",$J)
     138 S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND
     139 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
     140 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
     141 Q
     142 ;
     143OC ; -- Cancelled
     144 G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ=""
     145 S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80)
     146 D UPDATE(1,"DC")
     147 Q
     148 ;
     149CR ; -- Cancelled [ack]
     150 D STATUS^ORCSAVE2(+ORIFN,1)
     151 Q
     152 ;
     153UA ; -- Unable to accept [ack]
     154UX ; -- Unable to change [ack]: NOT IN USE
     155 S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected
     156 S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80)
     157 D STATUS^ORCSAVE2(+ORIFN,13)
     158UC ; -- Unable to cancel [ack]
     159DE ; -- Data Error [ack]
     160 N DA S DA=$P(ORIFN,";",2) Q:'DA
     161 S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
     162 S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240)
     163 Q
     164 ;
     165UPDATE(ORSTS,ORACT) ; -- continue processing
     166 N DA,ORX,ORCMMT,ORP
     167 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     168 D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
     169 S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX
     170 . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ)
     171 . I DA'>0 S ORERR="Cannot create new order action" Q
     172 . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
     173 . D SIGSTS^ORCSAVE2(+ORIFN,DA)
     174 . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     175 . S $P(^OR(100,+ORIFN,3),U,7)=DA
     176 I 'ORX,'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
     177 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
     178 Q
     179 ;
     180REASON() ; -- Get reason from OREASON or NTE segments
     181 N NTE,CMMT,X,Y,I,L
     182 S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5)
     183 G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments
     184 S Y=$P(@ORMSG@(NTE),"|",4),I=0
     185 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q
     186 S $P(CMMT,U,2)=Y
     187RQ Q CMMT

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS.m

    r613 r623  
    1 ORMPS   ; SLC/MKB - Process Pharmacy ORM msgs ;02/06/2007  10:32
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN      ; -- entry point
    5         I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
    6         I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
    7         N ORSTS,RXE,ZRX,ORWHO,ORNOW
    8         S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE
    9         S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ
    10         S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds
    11         S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5)
    12         I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE"
    13         D @ORDCNTRL
    14         Q
    15         ;
    16 ZV      ; -- Verified
    17         N ORUSR,ORVER,ORDA,ORES,ORI
    18         S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR
    19         S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)=""
    20         Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8)  ;already verified
    21         D REPLCD^ORCACT1 ;get unverified replaced orders
    22         S ORI="" F  S ORI=$O(ORES(ORI)) Q:ORI=""  D
    23         . S ORDA=+$P(ORI,";",2)
    24         . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG)
    25         Q
    26         ;
    27 ZP      ; -- Purged
    28         Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
    29         K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ;Remove pkg reference, sts=lapsed if still active
    30         Q
    31         ;
    32 ZR      ; -- Purged as requested [ack]
    33         D DELETE^ORCSAVE2(+ORIFN)
    34         Q
    35         ;
    36 ZU      ; -- Unable to purge [ack]
    37         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity
    38         Q
    39         ;
    40 XR      ; -- Changed as requested [ack]
    41         N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12)
    42 OK      ; -- Order accepted, PS order # assigned [ack]
    43         S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier
    44         D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
    45         Q
    46         ;
    47 ZC      ; -- convert orders
    48         N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT
    49         I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
    50         I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
    51         I 'RXE S ORERR="Missing or invalid RXE segment" Q
    52         S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J)
    53         D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
    54 ZC1     ; continue
    55         Q:$D(ORERR)  I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D  Q  ;create
    56         . K ORIFN D SN1 Q:'$G(ORIFN)  S ORDCNTRL="SN"
    57         . I ORSTOP,ORSTOP<ORNOW S $P(^OR(100,ORIFN,3),U)=ORSTOP
    58         S ORIFN=+ORIFN D RESPONSE^ORCSAVE K ^TMP("ORWORD",$J)
    59         S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
    60         D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP),STATUS^ORCSAVE2(ORIFN,ORSTS):ORSTS
    61         Q
    62         ;
    63 SN      ; -- New backdoor order, return OE# via NA msg
    64         I $$FINISHED^ORMPS2 D RO^ORMPS2 Q  ;change action instead
    65         N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC
    66         I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
    67         I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
    68         ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
    69         I 'RXE S ORERR="Missing or invalid RXE segment" Q
    70         S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J),ORIFN
    71         D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
    72 SN1     ; save order
    73         D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" G SNQ
    74         D BDOSTR^ORWDBA3 ;DG1 & ZCL data
    75         S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4) I ORIG D  ;set fwd/bwd ptrs
    76         . S TYPE=$S(TYPE="R":2,1:1) Q:'$D(^OR(100,ORIG,0))
    77         . S $P(^OR(100,ORIFN,3),U,5)=ORIG,$P(^(3),U,11)=TYPE
    78         . S $P(^OR(100,ORIG,3),U,6)=ORIFN,EVNT=$P(^(0),U,17)
    79         . I $L(EVNT),TYPE=1 S $P(^OR(100,ORIFN,0),U,17)=EVNT
    80         . I TYPE=2,$G(ORCAT)="I" S ORSTRT=ORLOG D PARENT^ORMPS3 ;ck if complex
    81         I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC
    82 SN2     D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
    83         D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
    84         D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
    85         ; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd
    86         S ORSIG=1 ;$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0)
    87         D SIGSTS^ORCSAVE2(ORIFN,1):ORSIG,SIGN^ORCSAVE2(ORIG,,,5,1):'ORSIG
    88         I ORDCNTRL="SN" D  ;print
    89         . S:ORNATR="" $P(^OR(100,ORIFN,8,1,0),U,12)="" ;CHCS/OP orders
    90         . S ORP(1)=ORIFN_";1"_$S(ORNATR="":"^^^^1",$G(ORL):"^1",1:"")
    91         . I ORP(1)["^" D PRINTS^ORWD1(.ORP,+$G(ORL))
    92         S ^OR(100,ORIFN,4)=PKGIFN
    93 SNQ     K ^TMP("ORWORD",$J)
    94         Q
    95         ;
    96 XX      ; -- Changed (new order not necessary)
    97         Q:$P($G(^OR(100,+ORIFN,3)),U,3)=5  ;pending - update when finished
    98         I '$$CHANGED^ORMPS2 D SC Q  ;ck sts/dates only
    99 RO      ; -- Replacement order (finished)
    100         S:ORNATR="" ORNATR="S" D RO^ORMPS2
    101         Q
    102         ;
    103 SC      ; -- Status changed (verified, expired, suspended, renewed, reinstate)
    104         N OR0,OR3,ZSC,DONE S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
    105         I "^1^13^"[(U_$P(OR3,U,3)_U),ORSTS=7 Q  ;retain DC status
    106         I $P(OR3,U,3)=5,ORSTS=6 D  Q:$G(DONE)
    107         . I $$CHANGED^ORMPS2 S ORNATR="S" D RO^ORMPS2 S DONE=1 Q
    108         . I $P(ZRX,"|",7)="TPN",+$P(OR0,U,11)'=$O(^ORD(100.98,"B","TPN",0)) D
    109         .. N DA,DR,DIE,ORDG S ORDG=+$O(^ORD(100.98,"B","TPN",0))
    110         .. S DA=+ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
    111         . I $P(OR3,U,11)=2,$P(OR0,U,12)="I" S ORSTRT=+$P($G(^OR(100,+ORIFN,8,1,0)),U,16) ;use Release Date for inpt renewals
    112         I $P(OR0,U,12)="I",$P(ZRX,"|",4)="R",+$P(ZRX,"|",2)=+ORIFN S ORSTRT=$P(OR0,U,8) ;keep orig start when renewed
    113         I ORSTS=7,ORSTOP S $P(^OR(100,+ORIFN,6),U,6)=ORSTOP ;save exp date
    114         I ORSTS=1 D EXPDT
    115         D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    116         D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
    117         I ORSTS=$P(OR3,U,3),ORSTOP'=$P(OR0,U,9) D SETALL^ORDD100(+ORIFN) ;AC xrf
    118         S ^OR(100,+ORIFN,4)=PKGIFN
    119         I "^1^13^"[(U_$P(OR3,U,3)_U),"^3^5^6^15^"[(U_ORSTS_U) D  ;reinstated
    120         . I $P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="DC" S ^(2)=ORNOW_U_ORWHO ; When^Who reinstated order
    121         . S I="?" F  S I=$O(^OR(100,+ORIFN,8,I),-1) Q:'+I  I $P(^(I,0),U,15)="" S $P(^OR(100,+ORIFN,3),U,7)=I Q  ;138 Finds current action
    122         . K ^OR(100,+ORIFN,6) D SETALL^ORDD100(+ORIFN)
    123         D UPD^ORMPS3 ;update some responses
    124         Q
    125         ;
    126 STATUS(X)       ; -- HL7 order status
    127         N Y S Y=$S(X="IP":5,X="CM":6,X="DC":1,X="ZE":7,X="HD":3,X="ZX":11,X="RP":12,X="ZZ":15,X="ZS":6,X="ZU":6,1:"")
    128         Q Y
    129         ;
    130 DE      ; -- Data Errors
    131         Q
    132         ;
    133 UA      ; -- Unable to accept [ack]
    134 UX      ; -- Unable to change [ack]
    135         S:'$L(ORNATR) ORNATR="X" ;Rejected
    136         S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON
    137         I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr if pending renewal
    138         D STATUS^ORCSAVE2(+ORIFN,13)
    139 UC      ; -- Unable to cancel [ack]
    140 UD      ; -- Unable to discontinue [ack]
    141 UH      ; -- Unable to hold [ack]
    142 UR      ; -- Unable to release hold [ack]
    143         N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D
    144         . S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected
    145         . S:$L(OREASON) ^OR(100,+ORIFN,8,ORDA,1)=OREASON
    146         Q
    147         ;
    148 OC      ; -- Cancelled (before pharmacist's verification)
    149         G:ORTYPE="ORR" UA S:ORNATR="A" ORWHO=""
    150         S:'ORSTS ORSTS=13 S:ORSTS=12 ORNATR="S"
    151         S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON
    152         I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr when pending renewal cancelled
    153         S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
    154         D EXPDT,UPDATE(ORSTS,"DC")
    155         Q
    156         ;
    157 CR      ; -- Cancelled [ack]
    158         D EXPDT ;save exp date, if past
    159         D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN
    160         Q
    161         ;
    162 OD      ; -- Discontinued (cancelled after pharmacist's verification)
    163         S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C"
    164         I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order#
    165         S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON
    166         S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
    167         D EXPDT,UPDATE(ORSTS,"DC")
    168         Q
    169         ;
    170 DR      ; -- Discontinued [ack]
    171         D EXPDT ;save exp date, if past
    172         D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN
    173         Q
    174         ;
    175 EXPDT   ; -- save exp date when dc'd
    176         N STOP S STOP=$P($G(^OR(100,+ORIFN,0)),U,9)
    177         I STOP,STOP<ORNOW,'$P($G(^OR(100,+ORIFN,6)),U,6) S $P(^(6),U,6)=STOP
    178         Q
    179         ;
    180 OH      ; -- Held
    181         S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD")
    182         Q
    183         ;
    184 HR      ; -- Held [ack]
    185         D STATUS^ORCSAVE2(+ORIFN,3)
    186         Q
    187         ;
    188 RL      ; -- Released hold
    189 OE      ; -- Released hold
    190         N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7)
    191         I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO
    192         S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL")
    193         Q
    194         ;
    195 OR      ; -- Released / [ack]
    196         S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
    197         D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    198         Q
    199         ;
    200 UPDATE(ORSTS,ORACT)     ; -- continue
    201         N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
    202         D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
    203         S ORX=$$CREATE^ORX1(ORNATR) D:ORX
    204         . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO)
    205         . I ORDA'>0 S ORERR="Cannot create new order action" Q
    206         . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
    207         . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
    208         . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    209         . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
    210         I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
    211         D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
    212         Q
    213         ;
    214 RXO()   ; -- RXO segment
    215         N I,X S X="",I=$O(@ORMSG@(+ORC))
    216         I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I)
    217         Q X
    218         ;
    219 RXE()   ; -- RXE segment
    220         N X,I,SEG S X="",I=+ORC
    221         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="RXE" S X=I_U_@ORMSG@(I) Q
    222         Q X
    223         ;
    224 RXR()   ; -- RXR segment
    225         N X,I,SEG S X="",I=+RXE
    226         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="RXR" S X=I_U_@ORMSG@(I) Q
    227         Q X
    228         ;
    229 RXC()   ; -- [First] RXC segment
    230         N X,I,SEG S X="",I=+RXE
    231         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="RXC" S X=I Q
    232         Q X
    233         ;
    234 ZRX()   ; -- ZRX segment
    235         N X,I,SEG S X="",I=+ORC
    236         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="ZRX" S X=I_U_@ORMSG@(I) Q
    237         Q X
     1ORMPS ; SLC/MKB - Process Pharmacy ORM msgs ;12/3/03  10:32
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195**;Dec 17, 1997
     3 ;
     4EN ; -- entry point
     5 I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
     6 I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
     7 N ORSTS,RXE,ZRX,ORWHO,ORNOW
     8 S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE
     9 S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ
     10 S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds
     11 S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5)
     12 I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE"
     13 D @ORDCNTRL
     14 Q
     15 ;
     16ZV ; -- Verified
     17 N ORUSR,ORVER,ORDA,ORES,ORI
     18 S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR
     19 S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)=""
     20 Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8)  ;already verified
     21 D REPLCD^ORCACT1 ;get unverified replaced orders
     22 S ORI="" F  S ORI=$O(ORES(ORI)) Q:ORI=""  D
     23 . S ORDA=+$P(ORI,";",2)
     24 . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG)
     25 Q
     26 ;
     27ZP ; -- Purged
     28 Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))
     29 K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ;Remove pkg reference, sts=lapsed if still active
     30 Q
     31 ;
     32ZR ; -- Purged as requested [ack]
     33 D DELETE^ORCSAVE2(+ORIFN)
     34 Q
     35 ;
     36ZU ; -- Unable to purge [ack]
     37 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity
     38 Q
     39 ;
     40XR ; -- Changed as requested [ack]
     41 N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12)
     42OK ; -- Order accepted, PS order # assigned [ack]
     43 S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier
     44 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
     45 Q
     46 ;
     47ZC ; -- convert orders
     48 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT
     49 I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
     50 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
     51 I 'RXE S ORERR="Missing or invalid RXE segment" Q
     52 S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J)
     53 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
     54ZC1 ; continue
     55 Q:$D(ORERR)  I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D  Q  ;create
     56 . K ORIFN D SN1 Q:'$G(ORIFN)  S ORDCNTRL="SN"
     57 . I ORSTOP,ORSTOP<ORNOW S $P(^OR(100,ORIFN,3),U)=ORSTOP
     58 S ORIFN=+ORIFN D RESPONSE^ORCSAVE K ^TMP("ORWORD",$J)
     59 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
     60 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP),STATUS^ORCSAVE2(ORIFN,ORSTS):ORSTS
     61 Q
     62 ;
     63SN ; -- New backdoor order, return OE# via NA msg
     64 I $$FINISHED^ORMPS2 D RO^ORMPS2 Q  ;change action instead
     65 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC
     66 I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
     67 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
     68 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
     69 I 'RXE S ORERR="Missing or invalid RXE segment" Q
     70 S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J),ORIFN
     71 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
     72SN1 ; save order
     73 D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" G SNQ
     74 D BDOSTR^ORWDBA3 ;DG1 & ZCL data
     75 S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4) I ORIG D  ;set fwd/bwd ptrs
     76 . S TYPE=$S(TYPE="R":2,1:1) Q:'$D(^OR(100,ORIG,0))
     77 . S $P(^OR(100,ORIFN,3),U,5)=ORIG,$P(^(3),U,11)=TYPE
     78 . S $P(^OR(100,ORIG,3),U,6)=ORIFN,EVNT=$P(^(0),U,17)
     79 . I $L(EVNT),TYPE=1 S $P(^OR(100,ORIFN,0),U,17)=EVNT
     80 . I TYPE=2,$G(ORCAT)="I" S ORSTRT=ORLOG D PARENT^ORMPS3 ;ck if complex
     81 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC
     82SN2 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
     83 D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
     84 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
     85 ; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd
     86 S ORSIG=$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0)
     87 D SIGSTS^ORCSAVE2(ORIFN,1):ORSIG,SIGN^ORCSAVE2(ORIG,,,5,1):'ORSIG
     88 I ORDCNTRL="SN" D  ;print
     89 . S:ORNATR="" $P(^OR(100,ORIFN,8,1,0),U,12)="" ;CHCS/OP orders
     90 . S ORP(1)=ORIFN_";1"_$S(ORNATR="":"^^^^1",$G(ORL):"^1",1:"")
     91 . I ORP(1)["^" D PRINTS^ORWD1(.ORP,+$G(ORL))
     92 S ^OR(100,ORIFN,4)=PKGIFN
     93SNQ K ^TMP("ORWORD",$J)
     94 Q
     95 ;
     96XX ; -- Changed (new order not necessary)
     97 Q:$P($G(^OR(100,+ORIFN,3)),U,3)=5  ;pending - update when finished
     98 I '$$CHANGED^ORMPS2 D SC Q  ;ck sts/dates only
     99RO ; -- Replacement order (finished)
     100 S:ORNATR="" ORNATR="S" D RO^ORMPS2
     101 Q
     102 ;
     103SC ; -- Status changed (verified, expired, suspended, renewed, reinstate)
     104 N OR0,OR3,ZSC,DONE S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
     105 I $P(OR3,U,3)=5,ORSTS=6 D  Q:$G(DONE)
     106 . I $$CHANGED^ORMPS2 S ORNATR="S" D RO^ORMPS2 S DONE=1 Q
     107 . I $P(ZRX,"|",7)="TPN",+$P(OR0,U,11)'=$O(^ORD(100.98,"B","TPN",0)) D
     108 .. N DA,DR,DIE,ORDG S ORDG=+$O(^ORD(100.98,"B","TPN",0))
     109 .. S DA=+ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
     110 . I $P(OR3,U,11)=2,$P(OR0,U,12)="I" S ORSTRT=+$P($G(^OR(100,+ORIFN,8,1,0)),U,16) ;use Release Date for inpt renewals
     111 I $P(OR0,U,12)="I",$P(ZRX,"|",4)="R",+$P(ZRX,"|",2)=+ORIFN S ORSTRT=$P(OR0,U,8) ;keep orig start when renewed
     112 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     113 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
     114 I ORSTS=$P(OR3,U,3),ORSTOP'=$P(OR0,U,9) D SETALL^ORDD100(+ORIFN) ;AC xrf
     115 S ^OR(100,+ORIFN,4)=PKGIFN
     116 I "^1^13^"[(U_$P(OR3,U,3)_U),"^3^5^6^15^"[(U_ORSTS_U) D  ;reinstated
     117 . I $P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="DC" S ^(2)=ORNOW_U_ORWHO ; When^Who reinstated order
     118 . S I="?" F  S I=$O(^OR(100,+ORIFN,8,I),-1) Q:'+I  I $P(^(I,0),U,15)="" S $P(^OR(100,+ORIFN,3),U,7)=I Q  ;138 Finds current action
     119 . K ^OR(100,+ORIFN,6) D SETALL^ORDD100(+ORIFN)
     120 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC
     121 Q
     122 ;
     123STATUS(X) ; -- HL7 order status
     124 N Y S Y=$S(X="IP":5,X="CM":6,X="DC":1,X="ZE":7,X="HD":3,X="ZX":11,X="RP":12,X="ZZ":15,X="ZS":6,X="ZU":6,1:"")
     125 Q Y
     126 ;
     127DE ; -- Data Errors
     128 Q
     129 ;
     130UA ; -- Unable to accept [ack]
     131UX ; -- Unable to change [ack]
     132 S:'$L(ORNATR) ORNATR="X" ;Rejected
     133 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON
     134 I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr if pending renewal
     135 D STATUS^ORCSAVE2(+ORIFN,13)
     136UC ; -- Unable to cancel [ack]
     137UD ; -- Unable to discontinue [ack]
     138UH ; -- Unable to hold [ack]
     139UR ; -- Unable to release hold [ack]
     140 N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D
     141 . S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected
     142 . S:$L(OREASON) ^OR(100,+ORIFN,8,ORDA,1)=OREASON
     143 Q
     144 ;
     145OC ; -- Cancelled (before pharmacist's verification)
     146 G:ORTYPE="ORR" UA S:ORNATR="A" ORWHO=""
     147 S:'ORSTS ORSTS=13 S:ORSTS=12 ORNATR="S"
     148 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON
     149 I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr when pending renewal cancelled
     150 S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
     151 D UPDATE(ORSTS,"DC")
     152 Q
     153 ;
     154CR ; -- Cancelled [ack]
     155 D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN
     156 Q
     157 ;
     158OD ; -- Discontinued (cancelled after pharmacist's verification)
     159 S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C"
     160 I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order#
     161 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON
     162 S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
     163 D UPDATE(ORSTS,"DC")
     164 Q
     165 ;
     166DR ; -- Discontinued [ack]
     167 D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN
     168 Q
     169 ;
     170OH ; -- Held
     171 S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD")
     172 Q
     173 ;
     174HR ; -- Held [ack]
     175 D STATUS^ORCSAVE2(+ORIFN,3)
     176 Q
     177 ;
     178RL ; -- Released hold
     179OE ; -- Released hold
     180 N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7)
     181 I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO
     182 S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL")
     183 Q
     184 ;
     185OR ; -- Released / [ack]
     186 S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
     187 D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     188 Q
     189 ;
     190UPDATE(ORSTS,ORACT) ; -- continue
     191 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
     192 D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
     193 S ORX=$$CREATE^ORX1(ORNATR) D:ORX
     194 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO)
     195 . I ORDA'>0 S ORERR="Cannot create new order action" Q
     196 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
     197 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
     198 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     199 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
     200 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
     201 D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
     202 Q
     203 ;
     204RXO() ; -- RXO segment
     205 N I,X S X="",I=$O(@ORMSG@(+ORC))
     206 I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I)
     207 Q X
     208 ;
     209RXE() ; -- RXE segment
     210 N X,I,SEG S X="",I=+ORC
     211 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="RXE" S X=I_U_@ORMSG@(I) Q
     212 Q X
     213 ;
     214RXR() ; -- RXR segment
     215 N X,I,SEG S X="",I=+RXE
     216 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="RXR" S X=I_U_@ORMSG@(I) Q
     217 Q X
     218 ;
     219RXC() ; -- [First] RXC segment
     220 N X,I,SEG S X="",I=+RXE
     221 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="RXC" S X=I Q
     222 Q X
     223 ;
     224ZRX() ; -- ZRX segment
     225 N X,I,SEG S X="",I=+ORC
     226 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="ZRX" S X=I_U_@ORMSG@(I) Q
     227 Q X

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS1.m

    r613 r623  
    1 ORMPS1  ;SLC/MKB - Process Pharmacy ORM msgs cont ; 3/27/08 7:38am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 UDOSE   ; -- new Unit Dose order
    5         N ADMIN,QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR
    6         S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
    7         I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0))
    8         E  S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0))
    9         S ORPKG=+$$PKG("PSJ")
    10         D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1))
    11         S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS")
    12         S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE")
    13         S SCH=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES")
    14         S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY")
    15         S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION")
    16         S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME")
    17 UD1     S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5)
    18         I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
    19         S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD
    20         S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5)
    21         S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D
    22         . N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_""""
    23         . I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q  ;pre-POE orders
    24         . S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&")
    25         I 'ID,'S0 S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2))
    26         S:$L(ID) ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0)
    27         I LDOSE="" D  I LDOSE="" S ORERR="Unable to determine instructions" Q
    28         . I $G(RXC)'>0 D  Q  ;look for units/dose
    29         .. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q
    30         .. S:'$L(X) X=$$UNESC^ORMPS2($P($$FIND^ORM(+RXE,7),U,5)) S:$L(X) LDOSE=LDOSE_" "_X
    31         .. S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2)) ;force use of DD
    32         . F  D  Q:LDOSE'=""  S RXC=$O(@ORMSG@(RXC)) Q:'RXC  Q:$E(@ORMSG@(RXC),1,3)'="RXC"
    33         .. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI
    34         .. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units
    35         S ORDIALOG(INSTR,1)=$$UNESC^ORMPS2(LDOSE)
    36 UD2     S NTE=$$NTE^ORMPS3(21) I NTE D
    37         . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
    38         . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
    39         . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
    40         . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
    41         S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q
    42         S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG
    43         S X=$P(QT,U,2)
    44         S ORDIALOG(SCH,1)=$$UNESC^ORMPS2($P(X,"&"))
    45         S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2)
    46         S X=$P(QT,U,3) I $L(X) D  ;set only if previous order had duration
    47         . N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0)
    48         . S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION^ORMPS3(X)
    49         D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG
    50         D UNESCARR^ORMPS2("ORDIALOG")
    51         Q
    52 OUT     ; -- new Outpt order
    53         N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC
    54         S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0))
    55         S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0))
    56         S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG)
    57         S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG")
    58         S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")
    59         S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION")
    60         S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED")
    61         S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG")
    62         S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN")
    63         S PC=$$PTR("WORD PROCESSING 1")
    64         S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5)
    65         I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
    66         S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD
    67         S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5)
    68         I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&")
    69         I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$$UNESC^ORMPS2($P(PSDD,U,2))
    70 OUT1    S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11)
    71         S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13)
    72         S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99)
    73         S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X
    74         I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X
    75         S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D
    76         . S ORDIALOG(INSTR,I)=$$UNESC^ORMPS2($P(ORQT(I),U,8)),X=$P(ORQT(I),U)
    77         . S:$L(X) ORDIALOG(DOSE,I)=$$UNESC^ORMPS2($P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0)
    78         . S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=$$UNESC^ORMPS2(X)
    79         . S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION^ORMPS3(X)
    80         . S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X)
    81         S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D
    82         . S I=1,J=+RXR ;look for multiple RXR's
    83         . F  S J=$O(@ORMSG@(J)) Q:J'>0  S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR"  S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4)
    84 OUT2    S NTE=$$NTE^ORMPS3(6) I NTE D  ;Prov Comm ;D:'NTE PCOMM^ORMPS2
    85         . S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
    86         . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
    87         . S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U
    88         . S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)",ORDIALOG(PC,"FORMAT")="@" ;keep, don't show
    89         . N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN
    90         . S XORIFN=$G(ORIFN) S:XORIFN="" XORIFN=$P(RXR,"|",2) Q:XORIFN=""
    91         . S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",0)) Q:XCOMM=""
    92         . S XCNT=0 F  S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT=""  S XCOMMENT=^TMP("ORWORD",$J,PC,1,XCNT,0) D
    93         .. S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0)),XXCNT=0
    94         .. I XORCOMM="" F  S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT=""  S XORCOMM=$G(^(XXCNT,0)) Q:XORCOMM'=""
    95         .. I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@"
    96         S NTE=$$NTE^ORMPS3(7) I NTE D  ;Pat Instr
    97         . S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
    98         . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
    99         . S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U
    100         . S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)"
    101         S NTE=$$NTE^ORMPS3(21) I NTE D  ;Sig
    102         . S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
    103         . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
    104         . S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U
    105         . S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)"
    106         . S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig
    107 OUT3    I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig
    108         S ZSC=$$ZSC^ORMPS3,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0)
    109         Q
    110 IV      ; -- new IV order
    111         N IVTYP,IVTYPE S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS^ORMPS3'>1 G UDOSE
    112         N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS,ROUTE,ADMIN
    113         N RXR
    114         S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
    115         I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0))
    116         E  S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0))
    117         S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG)
    118         S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE")
    119         S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG
    120         S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE")
    121         S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
    122         S DAYS=$$PTR("DURATION"),IVTYPE=$$PTR("IV TYPE"),ADMIN=$$PTR("ADMIN TIMES")
    123 IV1     S NTE=$$NTE^ORMPS3(21) I NTE D
    124         . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
    125         . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
    126         . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
    127         . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
    128         N ORDAYS S ORDAYS=""
    129         S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3)
    130         S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS)
    131         S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS
    132         S ORDIALOG(IVTYPE,1)=IVTYP
    133         S X=$P($$FIND^ORM(+RXE,25),U,5)
    134         S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0
    135         F  D  S RXC=$O(@ORMSG@(RXC)) Q:'RXC  Q:$E(@ORMSG@(RXC),1,3)'="RXC"
    136         . S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI
    137         . S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5)
    138         . I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q
    139         . S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2
    140 IV2     ;
    141         S RXR=$$RXR^ORMPS
    142         S ROUTE=$P(RXR,"|",2)
    143         S ORDIALOG($$PTR("ROUTE"),1)=$P(ROUTE,U,4)
    144         I IVTYP="I" S X=$P($G(ORQT(1)),U,2) D
    145         .S:$L($P(X,"&")) ORDIALOG(SCH,1)=$P(X,"&")
    146         .S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2)
    147         D UNESCARR^ORMPS2("ORDIALOG")
    148         Q
    149 PKG(NMSP)       ; -- Return Package file ptr for NMSP
    150         N I S I=0
    151         F  S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1  Q:'$O(^(I,0))  ;no Addl Prefs
    152         Q I
    153 PTR(NAME)       ; -- Returns ien of prompt NAME in Order Dialog file #101.41
    154         Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
    155 QT      ; -- Unpiece the Q/T field from RXE
    156         I 'RXE S ORQT(1)=ORQT,ORQT=1 Q  ; nothing to reset
    157         N X,Y,I,J,P,SEG,DONE K ORQT
    158         S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0
    159         F  D  Q:DONE
    160         . S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q
    161         . I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q
    162         . I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q
    163         . S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q
    164         . S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~")
    165         S ORQT=I Q:'ORQT  ; else reset ORSTRT, ORSTOP, ORURG
    166         S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6)
    167         S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG)
    168         Q
     1ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;12/9/04  12:01
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275**;Dec 17, 1997;Build 7
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4UDOSE ; -- new Unit Dose order
     5 N QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR
     6 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
     7 I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0))
     8 E  S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0))
     9 S ORPKG=+$$PKG("PSJ")
     10 D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1))
     11 S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS")
     12 S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE"),SCH=$$PTR("SCHEDULE")
     13 S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY")
     14 S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION")
     15 S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME")
     16UD1 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5)
     17 I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
     18 S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD
     19 S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5)
     20 S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D
     21 . N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_""""
     22 . I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q  ;pre-POE orders
     23 . S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&")
     24 I 'ID,'S0 S ORDIALOG(DRGNM,1)=$P(PSDD,U,2)
     25 S:$L(ID) ORDIALOG(DOSE,1)=$P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0
     26 I LDOSE="" D  I LDOSE="" S ORERR="Unable to determine instructions" Q
     27 . I $G(RXC)'>0 D  Q  ;look for units/dose
     28 .. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q
     29 .. S:'$L(X) X=$P($$FIND^ORM(+RXE,7),U,5) S:$L(X) LDOSE=LDOSE_" "_X
     30 .. S ORDIALOG(DRGNM,1)=$P(PSDD,U,2) ;force use of DD
     31 . F  D  Q:LDOSE'=""  S RXC=$O(@ORMSG@(RXC)) Q:'RXC  Q:$E(@ORMSG@(RXC),1,3)'="RXC"
     32 .. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI
     33 .. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units
     34 S ORDIALOG(INSTR,1)=LDOSE
     35UD2 S NTE=$$NTE(21) I NTE D
     36 . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$P(@ORMSG@(NTE),"|",4)
     37 . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=@ORMSG@(NTE,I)
     38 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
     39 . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
     40 S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q
     41 S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG
     42 S ORDIALOG(SCH,1)=$P(QT,U,2),X=$P(QT,U,3)
     43 I $L(X) D  ;set only if previous order had duration
     44 . N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0)
     45 . S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION(X)
     46 D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG
     47 Q
     48OUT ; -- new Outpt order
     49 N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC
     50 S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0))
     51 S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0))
     52 S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG)
     53 S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG")
     54 S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")
     55 S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION")
     56 S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED")
     57 S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG")
     58 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN")
     59 S PC=$$PTR("WORD PROCESSING 1")
     60 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5)
     61 I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
     62 S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD
     63 S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5)
     64 I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&")
     65 I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$P(PSDD,U,2)
     66OUT1 S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11)
     67 S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13)
     68 S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99)
     69 S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X
     70 I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X
     71 S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D
     72 . S ORDIALOG(INSTR,I)=$P(ORQT(I),U,8),X=$P(ORQT(I),U)
     73 . S:$L(X) ORDIALOG(DOSE,I)=$P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0
     74 . S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=X
     75 . S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION(X)
     76 . S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X)
     77 S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D
     78 . S I=1,J=+RXR ;look for multiple RXR's
     79 . F  S J=$O(@ORMSG@(J)) Q:J'>0  S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR"  S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4)
     80OUT2 S NTE=$$NTE(6) D:'NTE PCOMM^ORMPS2 I NTE D  ;Prov Comm
     81 . S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$P(@ORMSG@(NTE),"|",4)
     82 . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=@ORMSG@(NTE,I)
     83 . S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U
     84 . S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)"
     85 . N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN
     86 . S (XCOMM,XORCOMM)=""
     87 . S XORIFN=$G(ORIFN) I XORIFN="" S XORIFN=$P(RXR,"|",2)
     88 . Q:XORIFN=""
     89 . S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",XCOMM)) Q:XCOMM=""
     90 . S XCNT=0 F  S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT=""  S XCOMMENT=$G(^TMP("ORWORD",$J,PC,1,XCNT,0)) D
     91 . . S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0))
     92 . . S XXCNT=0
     93 . . I XORCOMM="" F  S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT=""  S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT,0)) Q:XORCOMM'=""
     94 . . I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@"
     95 S NTE=$$NTE(7) I NTE D  ;Pat Instr
     96 . S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$P(@ORMSG@(NTE),"|",4)
     97 . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=@ORMSG@(NTE,I)
     98 . S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U
     99 . S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)"
     100 S NTE=$$NTE(21) I NTE D  ;Sig
     101 . S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$P(@ORMSG@(NTE),"|",4)
     102 . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=@ORMSG@(NTE,I)
     103 . S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U
     104 . S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)"
     105 . S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig
     106OUT3 I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig
     107 S ZSC=$$ZSC,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0)
     108 Q
     109IV ; -- new IV order
     110 N IVTYP S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS'>1 G UDOSE
     111 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS
     112 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
     113 I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0))
     114 E  S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0))
     115 S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG)
     116 S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE")
     117 S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG
     118 S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE")
     119 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
     120 S DAYS=$$PTR("DURATION")
     121IV1 S NTE=$$NTE(21) I NTE D
     122 . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$P(@ORMSG@(NTE),"|",4)
     123 . I $O(@ORMSG@(NTE,0)) S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I'>0  S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=@ORMSG@(NTE,I)
     124 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
     125 . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
     126 N ORDAYS S ORDAYS=""
     127 S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3)
     128 S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS)
     129 S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS
     130 S X=$P($$FIND^ORM(+RXE,25),U,5)
     131 S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0
     132 F  D  S RXC=$O(@ORMSG@(RXC)) Q:'RXC  Q:$E(@ORMSG@(RXC),1,3)'="RXC"
     133 . S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI
     134 . S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5)
     135 . I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q
     136 . S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2
     137 I IVTYP="" S X=$P($G(ORQT(1)),U,2) S:$L(X) ORDIALOG(SCH,1)=X
     138 Q
     139NTE(ID) ; -- Return subscript of NTE segment for RXE-<ID>
     140 N I,SEG,Y S Y="",I=+RXE S:'$G(ID) ID=21
     141 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=@ORMSG@(I) Q:$E(SEG,1,3)="ORC"  I $P(SEG,"|",1,2)=("NTE|"_ID) S Y=I Q
     142 Q Y
     143ZSC() ; -- Return subscript of ZSC segment
     144 N I,SEG,Y S Y="",I=+RXE
     145 F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="ZSC" S Y=I_U_@ORMSG@(I) Q
     146 Q Y
     147NUMADDS() ; -- count number of additives to determine type
     148 N CNT,I,X S CNT=0,I=+RXE
     149 F  S I=$O(@ORMSG@(I)) Q:I'>0  S X=@ORMSG@(I) Q:$P(X,"|")="ORC"  I $E(X,1,6)="RXC|A|" S CNT=CNT+1
     150 Q CNT
     151PKG(NMSP) ; -- Return Package file ptr for NMSP
     152 N I S I=0
     153 F  S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1  Q:'$O(^(I,0))  ;no Addl Prefs  DBIA #2058
     154 Q I
     155PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
     156 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     157DURATION(X) ; -- Returns "# units" from U# format
     158 N Y,Y1,Y2 I X'?.1U1.N Q ""
     159 S Y1=$E(X),Y2=+$E(X,2,$L(X)) I X=+X S Y1="D",Y2=+X
     160 S Y=Y2_" "_$S(Y1="L":"MONTH",Y1="W":"WEEK",Y1="H":"HOUR",Y1="M":"MINUTE",Y1="S":"SECOND",1:"DAY")_$S(Y2>1:"S",1:"")
     161 Q Y
     162QT ; -- Unpiece the Q/T field from RXE
     163 I 'RXE S ORQT(1)=ORQT,ORQT=1 Q  ; nothing to reset
     164 N X,Y,I,J,P,SEG,DONE K ORQT
     165 S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0
     166 F  D  Q:DONE
     167 . S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q
     168 . I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q
     169 . I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q
     170 . S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q
     171 . S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~")
     172 S ORQT=I Q:'ORQT  ; else reset ORSTRT, ORSTOP, ORURG
     173 S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6)
     174 S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG)
     175 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS2.m

    r613 r623  
    1 ORMPS2  ;SLC/MKB - Process Pharmacy ORM msgs cont ;04/01/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 FINISHED()      ; -- new order [SN^ORMPS] due to finishing?
    6         N Y,ORIG,TYPE,ORIG4 S Y=0
    7         S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4))
    8         I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1
    9         Q Y
    10         ;
    11 WPX()   ; -- Compare comments in @ORMSG@(NTE) with order ORIFN
    12         ;     Returns 1 if different, or 0 if same
    13         N NTE,SPINST,Y,X S Y=0
    14         S NTE=+$$NTE^ORMPS3(21),SPINST=$S(NTE:$$NTXT^ORMPS3(NTE),1:"")
    15         S X=$$VALTXT^ORMPS3(+ORIFN,"COMMENT")
    16         I $TR(X," ")'=$TR(SPINST," ") S Y=1 ;comp text w/o spaces
    17 WQ      Q Y
    18         ;
    19 IVX()   ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV
    20         N Y,RXC,DG,OI,PSOI,XC,X,RATE,RXR,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT
    21         S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y  ;not IV of any kind
    22         S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3)
    23         I DG'="IV RX",DG'="TPN" D  Q Y  ;not fluid
    24         . I $P(ZRX,"|",7)'="" S Y=1 Q
    25         . I $$NUMADDS^ORMPS3>1 S Y=1 Q
    26         . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
    27         . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q
    28         . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5)
    29         . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q
    30 IV1     S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5)
    31         S:$L(UNT) RATE=RATE_" "_UNT S X=$$VALUE("RATE") I RATE'=X D  Q:Y Y
    32         . S:RATE["@" RATE=$P(RATE,"@") S:X["@" X=$P(X,"@") ;rate@labels
    33         . I RATE'=X S Y=1 Q
    34         I $P(ZRX,"|",7)'=$$VALUE("TYPE") S Y=1 Q Y
    35         S RXR=$$RXR^ORMPS
    36         I $P($P(RXR,"|",2),U,4)'=$$VALUE("ROUTE") S Y=1 Q Y
    37         S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC
    38         F  S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC"  D  S I=$O(@ORMSG@(I)) Q:I'>0
    39         . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5)
    40         . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units
    41         F I="STRENGTH","UNITS","VOLUME" D  ;ORX(I,inst)=value
    42         . S J=0 F  S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0  D
    43         .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3)
    44         .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1))
    45         S I=0 F  S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D  Q:Y
    46         . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1))
    47         . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
    48         . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D  Q
    49         .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2)
    50         .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q
    51         .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q
    52         .. K ORX("A",PSOI) ;same
    53         . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D  Q
    54         .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI))
    55         .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q
    56         .. K ORX("B",PSOI) ;same
    57         . S Y=1
    58         I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed
    59         Q Y
    60         ;
    61 CHANGED()       ; -- Compare ORMSG to order ORIFN, return 1 if different
    62         N I,X,Y,X1,NTE,SIG,PI,TRXO S Y=0
    63         I $G(ORCAT)="I" D  G CHQ
    64         . I $$WPX S Y=1 Q  ;Special Instructions
    65         . S X=$$VALUE("DAYS") ;duration
    66         . I $G(X)'="" D  I $G(X)'=X1 S Y=1 Q
    67         . .S X=$$HL7IVLMT^ORMBLDP1(X)
    68         . .S TRXO=$$RXO^ORMPS,X1=$P($P($G(TRXO),"|",2),U,3)
    69         . .;S X1=$$DURATION^ORMPS3($P($P(TRXO,"|",2),U,3))
    70         . I $$IVX S Y=1 Q  ;IV fields
    71         ;S X=+$P($P(RXE,"|",3),U,4) I X'=+$$VALUE("DRUG") S Y=1 G CHQ
    72         I +$P(RXE,"|",11)'=+$$VALUE("QTY") S Y=1 G CHQ
    73         I +$P(RXE,"|",13)'=+$$VALUE("REFILLS") S Y=1 G CHQ
    74         ;S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=+$$VALUE("SUPPLY") S Y=1 G CHQ
    75         ;I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ
    76         S NTE=$$NTE^ORMPS3(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb
    77         I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ
    78         S NTE=$$NTE^ORMPS3(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0))
    79         I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted
    80         I NTE,PI D  G CHQ ;compare text
    81         . S PI=$$VALTXT^ORMPS3(+ORIFN,PI)_$$VALTXT^ORMPS3(+ORIFN,"COMMENT")
    82         . S NTE=$$NTXT^ORMPS3(NTE)
    83         . I $TR(NTE," ")'=$TR(PI," ") S Y=1 Q  ;comp text w/o spaces
    84 CHQ     Q Y
    85         ;
    86 VALUE(ID)       ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID")
    87         N I,Y I '$L($G(ID)) Q ""
    88         S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0))
    89         S Y=$G(^OR(100,+ORIFN,4.5,I,1))
    90         Q Y
    91         ;
    92 PTR(X)  ; -- Return ptr to prompt OR GTX X
    93         Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
    94         ;
    95 RO      ; -- Replacement order (finished)
    96         N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS
    97         N ADMIN,IVTYPE
    98         K ^TMP("ORWORD",$J)
    99         I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
    100         I 'RXE S ORERR="Missing or invalid RXE segment" Q
    101         S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN)
    102         I ORIFN'>0 S ORERR="Missing or invalid order number" Q
    103         D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
    104         ;Check keep Admin Time with order if not define in the RXE segment on
    105         ;verify
    106         I RXC,$$VALUE("TYPE")="I" S ORDIALOG($$PTR("ADMIN TIMES"),1)=$$VALUE("ADMIN")
    107         S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO)
    108         I ORDA'>0 S ORERR="Cannot create new order action" Q
    109 RO1     ; -Update sts of order to active, last action to dc/edit:
    110         S ORX=ORDA F  S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0  I $D(^(ORX,0)),$P(^(0),U,15)="" Q  ;ORX=last released action
    111         S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit
    112         S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6)
    113         D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS
    114         D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
    115         D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
    116         ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
    117         S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
    118         D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
    119 RO2     ; -Update responses, get/save new order text:
    120         K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
    121         S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG
    122         ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D  ;update DG,xrefs
    123         ;AGP Changes to handle IMO IV orders CPRS 26v43
    124         I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D
    125         . N DA,DR,DIE
    126         . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
    127         S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA
    128         S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back
    129         I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    130         I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC in #100
    131         Q
    132 IVLIM(IVDUR)    ;
    133         I $L(IVDUR) D
    134         . N DURU,DURV S DURU="",DURV=0
    135         . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
    136         . I IVDUR["dose" S DURV=$E(IVDUR,6,$L(IVDUR)),IVDUR="for a total of "_+DURV_$S(+DURV=1:" doses",+DURV>1:" doses",1:" dose") Q
    137         . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
    138         . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
    139         . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
    140         . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
    141         Q IVDUR
    142 UNESC(STRING)   ;
    143         Q $$UNESC^ORHLESC(STRING)
    144 UNESCARR(ARR)   ;
    145         N I S I="" F  S I=$O(@ARR@(I)) Q:'$L(I)  D
    146         .N IND S IND=$S(ARR["(":$E(ARR,0,$L(ARR)-1)_","""_I_""")",1:ARR_"("""_I_""")")
    147         .N TYPE S TYPE=$D(@ARR@(I))
    148         .I TYPE=11!(TYPE=10) D UNESCARR(IND)
    149         .I TYPE=1!(TYPE=11) S @ARR@(I)=$$UNESC(@ARR@(I))
    150         Q
    151 PCOMM   ; -- Get Provider Comments from previous order, when changed
    152         N OLD,I
    153         S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1
    154         S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1
    155         Q:'$O(^OR(100,OLD,4.5,I,2,0))  ;none
    156         M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2)
    157         S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)"
    158         S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already
    159         Q
     1ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ; 1/26/07 11:58am
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265**;Dec 17, 1997;Build 17
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5FINISHED() ; -- new order [SN^ORMPS] due to finishing?
     6 N Y,ORIG,TYPE,ORIG4 S Y=0
     7 S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4))
     8 I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1
     9 Q Y
     10 ;
     11WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN
     12 ;     Returns 1 if different, or 0 if same
     13 N NTE,SPINST,Y,I,J,X,X1 S Y=0
     14 S NTE=+$$NTE^ORMPS1(21),SPINST=$S(NTE:$P(@ORMSG@(NTE),"|",4),1:"")
     15 S I=+$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",0)) I I'>0 S:$L(SPINST) Y=1 G WQ
     16 S X=$G(^OR(100,+ORIFN,4.5,I,2,1,0)) ;1st line
     17 I '$O(^OR(100,+ORIFN,4.5,I,2,1)) S:X'=SPINST Y=1 G WQ
     18 S J=1 F  S J=$O(^OR(100,+ORIFN,4.5,I,2,J)) Q:J'>0  S X1=$G(^(J,0)) D  Q:$L(X)'<240
     19 . I ($L(X)+$L(X1)+1)'>240 S X=X_" "_X1 Q
     20 . S X=X_" "_$E(X1,1,239-$L(X))
     21 S:X'=SPINST Y=1 ;changed
     22WQ Q Y
     23 ;
     24IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV
     25 N Y,RXC,DG,OI,PSOI,XC,RATE,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT
     26 S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y  ;not IV of any kind
     27 S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3)
     28 I DG'="IV RX",DG'="TPN" D  Q Y  ;not fluid
     29 . I $P(ZRX,"|",7)'="" S Y=1 Q
     30 . I $$NUMADDS^ORMPS1>1 S Y=1 Q
     31 . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
     32 . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q
     33 . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5)
     34 . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q
     35IV1 S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5)
     36 S:$L(UNT) RATE=RATE_" "_UNT I RATE'=$$VALUE("RATE") S Y=1 Q Y
     37 S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC
     38 F  S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC"  D  S I=$O(@ORMSG@(I)) Q:I'>0
     39 . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5)
     40 . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units
     41 F I="STRENGTH","UNITS","VOLUME" D  ;ORX(I,inst)=value
     42 . S J=0 F  S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0  D
     43 .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3)
     44 .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1))
     45 S I=0 F  S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D  Q:Y
     46 . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1))
     47 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
     48 . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D  Q
     49 .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2)
     50 .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q
     51 .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q
     52 .. K ORX("A",PSOI) ;same
     53 . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D  Q
     54 .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI))
     55 .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q
     56 .. K ORX("B",PSOI) ;same
     57 . S Y=1
     58 I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed
     59 Q Y
     60 ;
     61CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different
     62 N X,Y,X1,ZSC,NTE,SIG,PI S Y=0
     63 I $G(ORCAT)="I" D  G CHQ
     64 . I $$WPX S Y=1 Q  ;Special Instructions
     65 . ;S X=$$VALUE("DAYS") ;duration
     66 . ;I X S X1=$$DURATION^ORMPS1($P($G(ORQT(1)),U,3)) I X'=X1 S Y=1 Q
     67 . I $$IVX S Y=1 Q  ;IV fields
     68 S X=$P($P(RXE,"|",3),U,4) I X'=$$VALUE("DRUG") S Y=1 G CHQ
     69 I $P(RXE,"|",11)'=$$VALUE("QTY") S Y=1 G CHQ
     70 I $P(RXE,"|",13)'=$$VALUE("REFILLS") S Y=1 G CHQ
     71 S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=$$VALUE("SUPPLY") S Y=1 G CHQ
     72 I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ
     73 S NTE=$$NTE^ORMPS1(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb
     74 I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ
     75 S NTE=$$NTE^ORMPS1(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0))
     76 I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted
     77 I NTE,PI,$P(@ORMSG@(NTE),"|",4)'=$G(^OR(100,+ORIFN,4.5,PI,2,1,0)) S Y=1 G CHQ
     78 Q:'$P($G(^OR(100,+ORIFN,8,0)),U,3)
     79 N LSTACT,PREPRV,CURPRV S LSTACT="?",(PREPRV,CURPRV)=0
     80 F  S LSTACT=$O(^OR(100,+ORIFN,8,LSTACT),-1) Q:LSTACT
     81 S PREPRV=$P($G(^OR(100,+ORIFN,8,LSTACT,0)),U,3)
     82 S CURPRV=$P($G(ORC),"|",13)
     83 I (PREPRV'=CURPRV) S Y=1 G CHQ
     84CHQ Q Y
     85 ;
     86VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID")
     87 N I,Y I '$L($G(ID)) Q ""
     88 S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0))
     89 S Y=$G(^OR(100,+ORIFN,4.5,I,1))
     90 Q Y
     91 ;
     92PTR(X) ; -- Return ptr to prompt OR GTX X
     93 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
     94 ;
     95RO ; -- Replacement order (finished)
     96 ;
     97 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS
     98 K ^TMP("ORWORD",$J)
     99 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
     100 I 'RXE S ORERR="Missing or invalid RXE segment" Q
     101 S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN)
     102 I ORIFN'>0 S ORERR="Missing or invalid order number" Q
     103 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
     104 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO)
     105 I ORDA'>0 S ORERR="Cannot create new order action" Q
     106RO1 ; -Update sts of order to active, last action to dc/edit:
     107 S ORX=ORDA F  S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0  I $D(^(ORX,0)),$P(^(0),U,15)="" Q  ;ORX=last released action
     108 S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit
     109 S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6)
     110 D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS
     111 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
     112 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
     113 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
     114 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
     115 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
     116RO2 ; -Update responses, get/save new order text:
     117 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
     118 S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG
     119 ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D  ;update DG,xrefs
     120 ;AGP Changes to handle IMO IV orders CPRS 26v43
     121 I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D
     122 . N DA,DR,DIE
     123 . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
     124 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA
     125 S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back
     126 I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     127 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC in #100
     128 Q
     129IVLIM(IVDUR)    ;
     130 I $L(IVDUR) D
     131 . N DURU,DURV S DURU="",DURV=0
     132 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
     133 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
     134 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
     135 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
     136 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
     137 Q IVDUR
     138PCOMM ; -- Get Provider Comments from previous order, when changed
     139 N OLD,I
     140 S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1
     141 S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1
     142 Q:'$O(^OR(100,OLD,4.5,I,2,0))  ;none
     143 M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2)
     144 S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)"
     145 S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already
     146 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS3.m

    r613 r623  
    1 ORMPS3  ;SLC/MKB - Process Pharmacy ORM msgs cont ;05/08/2008  10:32
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**213,243**;Dec 17, 1997;Build 242
    3         ;
    4 PTR(X)  ; -- Return ptr to prompt OR GTX X
    5         Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
    6         ;
    7 PARENT  ; -- create parent order for backdoor complex renewals
    8         ;    Expects ORIFN, ORIG, ORDIALOG()
    9         ;Q:'$$PATCH^XPDUTL("PSJ*5.0*110")
    10         N ORIGDAD,ORIFNDAD,HDR S ORIGDAD=$P($G(^OR(100,ORIG,3)),U,9)
    11         Q:ORIGDAD<1  Q:$$DOSES^ORCACT4(ORIGDAD)'>1  ;cont if complex
    12         S ORIFNDAD=$P($G(^OR(100,ORIGDAD,3)),U,6) I ORIFNDAD<1 D  G P1
    13         . N ORIFN D EN^ORCSAVE Q:ORIFN<1
    14         . S $P(^OR(100,ORIFN,3),U,5)=ORIGDAD,$P(^(3),U,8)=1,$P(^(3),U,11)=2
    15         . S $P(^OR(100,ORIGDAD,3),U,6)=ORIFN,ORIFNDAD=ORIFN
    16         . D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
    17         . D SIGSTS^ORCSAVE2(ORIFN,1),DATES^ORCSAVE2(ORIFN,ORSTRT)
    18         . I $P(^OR(100,ORIFN,8,1,0),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;sign children instead
    19         . ;STATUS updated in SN2^ORMPS from child orders
    20 P0      ; -- just add conjunction, new dose if DAD already exists
    21         N INST,DA,PTR,ID,P,I,J,X
    22         S INST=$$DOSES^ORCACT4(ORIFNDAD),DA=$O(^OR(100,ORIFNDAD,4.5,"A"),-1)
    23         S PTR=$$PTR("AND/THEN"),ID="CONJ",DA=DA+1
    24         S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)="A"
    25         S ^OR(100,ORIFNDAD,4.5,"ID","CONJ",DA)="",INST=INST+1
    26         F P="INSTRUCTIONS","ROUTE","SCHEDULE","DURATION","DOSE","DISPENSE DRUG" D
    27         . S PTR=$$PTR(P) Q:'$L($G(ORDIALOG(PTR,1)))
    28         . S DA=DA+1,ID=$P($G(^ORD(101.41,PTR,1)),U,3)
    29         . S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)=ORDIALOG(PTR,1)
    30         . S ^OR(100,ORIFNDAD,4.5,"ID",ID,DA)=""
    31         S $P(^OR(100,ORIFNDAD,4.5,0),U,3,4)=DA_U_DA
    32         S P=$$PTR("SIG"),DA=+$O(^OR(100,ORIFNDAD,4.5,"ID","SIG",0))
    33         S I=+$O(^OR(100,ORIFNDAD,4.5,DA,2,""),-1),X=$G(^(I,0)) S:$L(X) X=X_" AND",^(0)=X
    34         S J=0 F  S J=$O(^TMP("ORWORD",$J,PTR,1,J)) Q:J<1  S I=I+1,^OR(100,ORIFNDAD,4.5,DA,2,I,0)=^TMP("ORWORD",$J,PTR,1,J,0)
    35         S $P(^OR(100,ORIFNDAD,4.5,DA,2,0),U,3,4)=I_U_I
    36         ; -- rebuild order text w/new SIG
    37         K ^TMP("ORWORD",$J,PTR) M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFNDAD,4.5,DA,2)
    38         K ^OR(100,ORIFNDAD,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFNDAD_";1")
    39 P1      ; -- set up links
    40         S $P(^OR(100,ORIFN,3),U,9)=ORIFNDAD
    41         S HDR=$G(^OR(100,ORIFNDAD,2,0)),^(0)="^100.002PA^"_ORIFN_U_($P(HDR,U,4)+1),^(ORIFN,0)=ORIFN
    42         Q
    43         ;
    44 NTE(ID) ; -- Return subscript of NTE|ID segment
    45         N I,SEG,Y S Y="",I=+RXE S:'$G(ID) ID=21
    46         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=@ORMSG@(I) Q:$E(SEG,1,3)="ORC"  I $P(SEG,"|",1,2)=("NTE|"_ID) S Y=I Q
    47         Q Y
    48         ;
    49 NTXT(NTE)       ; -- Return string of text in ORMSG(NTE)
    50         N Y,I S NTE=+$G(NTE)
    51         S Y=$P($G(@ORMSG@(NTE)),"|",4),Y=$$UNESC^ORHLESC(Y)
    52         S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I<1  S Y=Y_" "_$$UNESC^ORHLESC(@ORMSG@(NTE,I))
    53         Q Y
    54         ;
    55 ZSC()   ; -- Return subscript of ZSC segment
    56         N I,SEG,Y S Y="",I=+RXE
    57         F  S I=$O(@ORMSG@(I)) Q:I'>0  S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC"  I SEG="ZSC" S Y=I_U_@ORMSG@(I) Q
    58         Q Y
    59         ;
    60 NUMADDS()       ; -- count number of additives to determine type
    61         N CNT,I,X S CNT=0,I=+RXE
    62         F  S I=$O(@ORMSG@(I)) Q:I'>0  S X=@ORMSG@(I) Q:$P(X,"|")="ORC"  I $E(X,1,6)="RXC|A|" S CNT=CNT+1
    63         Q CNT
    64         ;
    65 DURATION(X)     ; -- Returns "# units" from U# format
    66         N Y,Y1,Y2 I X'?.1U1.N Q ""
    67         S Y1=$E(X),Y2=+$E(X,2,$L(X)) I X=+X S Y1="D",Y2=+X
    68         S Y=Y2_" "_$S(Y1="L":"MONTH",Y1="W":"WEEK",Y1="H":"HOUR",Y1="M":"MINUTE",Y1="S":"SECOND",1:"DAY")_$S(Y2>1:"S",1:"")
    69         Q Y
    70         ;
    71 UPD     ; -- Compare ORMSG to order, update responses [from SC^ORMPS]
    72         ;    Also expects ORIFN,ORNP,ORCAT,OR3,RXE,ZRX,PKGIFN
    73         N X,I,ORDER,ZSC,NTE,PI
    74         S ORDER=+$G(ORIFN),I=+$P(ORIFN,";",2) I I<1 D
    75         . S I=+$P(OR3,U,7) Q:I
    76         . S I=$O(^OR(100,+ORIFN,8,"A"),-1)
    77         S X=+$P($G(^OR(100,+ORIFN,8,I,0)),U,3) S:X'=ORNP $P(^(0),U,3)=ORNP
    78         S X=+$P($P(RXE,"|",3),U,4)
    79         I X,X'=+$$VALUE(ORDER,"DRUG") D RESP^ORCSAVE2(ORDER,"OR GTX DISPENSE DRUG",X)
    80         I $G(ORCAT)="I" D  Q
    81         . S X=$P($P($P(RXE,"|",2),U,2),"&",2)
    82         . I X'=$$VALUE(ORDER,"ADMIN") D RESP^ORCSAVE2(ORDER,"OR GTX ADMIN TIMES",X)
    83         . ;SCHEDULE TYPE
    84         . S X=$P($P(RXE,"|",2),U,7)
    85         . I X'=$$VALUE(ORDER,"SCHTYPE") D RESP^ORCSAVE2(ORDER,"OR GTX SCHEDULE TYPE",X)
    86         . I $S(X="P":1,X="O":1,X="OC":1,1:0) D
    87         . .D RESP^ORCSAVE2(ORDER,"OR GTX ADMIN TIMES","")
    88         I $G(PKGIFN)'["N" D  ;Rx only, not non-VA
    89         . S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99)
    90         . I +X'=+$$VALUE(ORDER,"SUPPLY") D RESP^ORCSAVE2(ORDER,"OR GTX DAYS SUPPLY",X)
    91         . I $P(ZRX,"|",5)'=$$VALUE(ORDER,"PICKUP") D RESP^ORCSAVE2(ORDER,"OR GTX ROUTING",$P(ZRX,"|",5))
    92         . S NTE=$$NTE(7),PI=+$O(^OR(100,ORDER,4.5,"ID","PI",0))
    93         . I NTE,PI,$$NTXT(NTE)'=$$VALTXT(ORDER,PI) D
    94         .. N CNT K ^OR(100,ORDER,4.5,PI,2)
    95         .. S CNT=1,^OR(100,ORDER,4.5,PI,2,1,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
    96         .. S I=0 F  S I=$O(@ORMSG@(NTE,I)) Q:I<1  S CNT=CNT+1,^OR(100,ORDER,4.5,PI,2,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
    97         .. S ^OR(100,ORDER,4.5,PI,2,0)="^^"_CNT_U_CNT_U_DT_U
    98         S ZSC=$$ZSC I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORDER,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC
    99         Q
    100         ;
    101 VALUE(IFN,ID,INST)      ; -- Returns value of prompt by identifier ID
    102         I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""
    103         N I,Y S I=0,Y="" S:'$G(INST) INST=1
    104         F  S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0  I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q
    105         Q Y
    106         ;
    107 VALTXT(IFN,ID)  ; -- Return string of text for prompt ID [assumes single instance]
    108         ;    ID may be identifier name or Response IEN
    109         N Y,DA,I S IFN=+$G(IFN),ID=$G(ID)
    110         S DA=$S($G(ID):+ID,$L(ID):+$O(^OR(100,IFN,4.5,"ID",ID,0)),1:0)
    111         S I=+$O(^OR(100,IFN,4.5,DA,2,0)),Y=$G(^(I,0))
    112         F  S I=$O(^OR(100,IFN,4.5,DA,2,I)) Q:I<1  S Y=Y_" "_$G(^(I,0))
    113         Q Y
     1ORMPS3 ;SLC/MKB - Process Pharmacy ORM msgs cont ;12/3/03  10:32
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**213**;Dec 17, 1997
     3 ;
     4PTR(X) ; -- Return ptr to prompt OR GTX X
     5 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
     6 ;
     7PARENT ; -- create parent order for backdoor complex renewals
     8 ;    Expects ORIFN, ORIG, ORDIALOG()
     9 ;Q:'$$PATCH^XPDUTL("PSJ*5.0*110")
     10 N ORIGDAD,ORIFNDAD,HDR S ORIGDAD=$P($G(^OR(100,ORIG,3)),U,9)
     11 Q:ORIGDAD<1  Q:$$DOSES^ORCACT4(ORIGDAD)'>1  ;cont if complex
     12 S ORIFNDAD=$P($G(^OR(100,ORIGDAD,3)),U,6) I ORIFNDAD<1 D  G P1
     13 . N ORIFN D EN^ORCSAVE Q:ORIFN<1
     14 . S $P(^OR(100,ORIFN,3),U,5)=ORIGDAD,$P(^(3),U,8)=1,$P(^(3),U,11)=2
     15 . S $P(^OR(100,ORIGDAD,3),U,6)=ORIFN,ORIFNDAD=ORIFN
     16 . D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
     17 . D SIGSTS^ORCSAVE2(ORIFN,1),DATES^ORCSAVE2(ORIFN,ORSTRT)
     18 . I $P(^OR(100,ORIFN,8,1,0),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;sign children instead
     19 . ;STATUS updated in SN2^ORMPS from child orders
     20P0 ; -- just add conjunction, new dose if DAD already exists
     21 N INST,DA,PTR,ID,P,I,J,X
     22 S INST=$$DOSES^ORCACT4(ORIFNDAD),DA=$O(^OR(100,ORIFNDAD,4.5,"A"),-1)
     23 S PTR=$$PTR("AND/THEN"),ID="CONJ",DA=DA+1
     24 S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)="A"
     25 S ^OR(100,ORIFNDAD,4.5,"ID","CONJ",DA)="",INST=INST+1
     26 F P="INSTRUCTIONS","ROUTE","SCHEDULE","DURATION","DOSE","DISPENSE DRUG" D
     27 . S PTR=$$PTR(P) Q:'$L($G(ORDIALOG(PTR,1)))
     28 . S DA=DA+1,ID=$P($G(^ORD(101.41,PTR,1)),U,3)
     29 . S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)=ORDIALOG(PTR,1)
     30 . S ^OR(100,ORIFNDAD,4.5,"ID",ID,DA)=""
     31 S $P(^OR(100,ORIFNDAD,4.5,0),U,3,4)=DA_U_DA
     32 S P=$$PTR("SIG"),DA=+$O(^OR(100,ORIFNDAD,4.5,"ID","SIG",0))
     33 S I=+$O(^OR(100,ORIFNDAD,4.5,DA,2,""),-1),X=$G(^(I,0)) S:$L(X) X=X_" AND",^(0)=X
     34 S J=0 F  S J=$O(^TMP("ORWORD",$J,PTR,1,J)) Q:J<1  S I=I+1,^OR(100,ORIFNDAD,4.5,DA,2,I,0)=^TMP("ORWORD",$J,PTR,1,J,0)
     35 S $P(^OR(100,ORIFNDAD,4.5,DA,2,0),U,3,4)=I_U_I
     36 ; -- rebuild order text w/new SIG
     37 K ^TMP("ORWORD",$J,PTR) M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFNDAD,4.5,DA,2)
     38 K ^OR(100,ORIFNDAD,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFNDAD_";1")
     39P1 ; -- set up links
     40 S $P(^OR(100,ORIFN,3),U,9)=ORIFNDAD
     41 S HDR=$G(^OR(100,ORIFNDAD,2,0)),^(0)="^100.002PA^"_ORIFN_U_($P(HDR,U,4)+1),^(ORIFN,0)=ORIFN
     42 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m

    r613 r623  
    1 ORMRA   ; SLC/MKB/RV - Process Radiology ORM msgs ;2/21/02  15:44 [05/30/06 12:30pm]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,243**;Dec 17, 1997;Build 242
    3         ;DBIA 2968 allows for reading ^DIC(34
    4 EN      ; -- entry point for RA messages
    5         I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
    6         I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
    7         S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2))
    8         S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12)
    9         D @ORDCNTRL
    10         Q
    11         ;
    12 ZP      ; -- Purged
    13         Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))  K ^OR(100,+ORIFN,4)
    14         ; - Set status=lapsed, if still active
    15         I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14)
    16         Q
    17         ;
    18 ZR      ; -- Purged as requested [ack]
    19         D DELETE^ORCSAVE2(+ORIFN)
    20         Q
    21         ;
    22 ZU      ; -- Unable to purge [ack]
    23         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
    24         Q
    25         ;
    26 OK      ; -- Order accepted, RA order # assigned [ack]
    27         N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending
    28         ; Ck if also scheduled, else quit
    29         S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ
    30         S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
    31         D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
    32 OKQ     D STATUS^ORCSAVE2(ORIFN,ORSTS)
    33         ;Save the Radiology pre-certification Account Reference in the PV1
    34         ;segment of the HL7 message from the Radiology package to the Order
    35         ;File (#100). Support for Patch OR*3.0*228
    36         I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2  ;IA #4663
    37         Q
    38         ;
    39 XX      ; -- Change order
    40         N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S"
    41         D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)  S ORIFN=+ORIFN
    42         S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
    43         I ORDA'>0 S ORERR="Cannot create new order action" Q
    44         ; -Update sts of order to active, last action to dc/edit:
    45         S ORX=+$P($G(^OR(100,ORIFN,3)),U,7)
    46         S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12
    47         S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6)
    48         D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
    49         ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
    50         S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
    51         D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
    52         ; -Update responses, get/save new order text:
    53         K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
    54         S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
    55         I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    56         Q
    57         ;
    58 SN      ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
    59         N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
    60         I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
    61         I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
    62         I '$G(ORL) S ORERR="Missing or invalid patient location" Q
    63         D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)
    64 SNQ     D EN^ORCSAVE K ^TMP("ORWORD",$J)
    65         I '$G(ORIFN) S ORERR="Cannot create new order" Q
    66         ;Save DG1 and ZCL segments of HL7 message from backdoor orders
    67         D BDOSTR^ORWDBA3
    68         ;Save the Radiology pre-certification Account Reference in the PV1
    69         ;segment of the HL7 message from the Radiology package to the Order
    70         ;File (#100). Support for Patch OR*3.0*228
    71         I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2  ;IA #4663
    72         D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
    73         D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN
    74         I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
    75         Q
    76         ;
    77 DLG     ; -- Build ORDIALOG() from msg
    78         N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE,REASON
    79         S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0))
    80         D GETDLG1^ORCD(ORDIALOG)
    81         S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
    82         S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
    83         S ORDIALOG($$PTR("URGENCY"),1)=ORURG
    84         S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12)
    85 D1      S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
    86         S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5))
    87         I 'OI S ORERR="Invalid procedure" Q
    88         S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
    89         S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type
    90         S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D
    91         . F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y
    92         S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31),REASON=$P($P(@ORMSG@(OBR),"|",32),U,2)
    93         S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC
    94         S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE))
    95         S:$L(REASON) ORDIALOG($$PTR("STUDY REASON"),1)=REASON
    96         I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments
    97 D2      ; might the procedure be scheduled at this point ??  Not in spec
    98         S CH=$$PTR("WORD PROCESSING 1"),CHI=0
    99         S OBX=OBR F  S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0  S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC"  Q:J="MSH"  I J="OBX" D
    100         . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6)
    101         . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2))
    102         . I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q
    103         . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q
    104         . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q
    105         . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q
    106         . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE
    107         S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)"
    108         Q
    109         ;
    110 PTR(X)  ; -- Returns ptr to prompt in Order Dialog file #101.41
    111         Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
    112         ;
    113 SC      ; -- Status changed (scheduled, registered, or unverified)
    114         N ORSTS,OBR,OR3 ;110
    115         S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110
    116         G:ORSTS=6 SCQ ;136  Done if active, else get scheduled data
    117         S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
    118         S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
    119         D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
    120         I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release.  Added with 110
    121 SCQ     D STATUS^ORCSAVE2(ORIFN,ORSTS)
    122         Q
    123         ;
    124 RE      ; -- Completed, w/results
    125         N I,SEG,OBX
    126         D STATUS^ORCSAVE2(ORIFN,2)
    127         S OBX="" D  ;get Results D/T [from OBR]
    128         . N DA,DR,DIE,X,Y,OBR
    129         . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X=""
    130         . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
    131         . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE
    132         S I=+ORC F  S I=$O(@ORMSG@(I)) Q:I<1  S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC"  I $E(SEG,1,3)="OBX" S OBX=I_U_SEG Q  ;first one
    133         S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"")
    134         S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
    135         I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
    136         Q
    137         ;
    138 OH      ; -- Held
    139         D UPDATE(3,"HD")
    140         Q
    141         ;
    142 OC      ; -- Cancelled/Unable to accept [ack]
    143 UA      ; -- Unable to accept [ack]
    144         S:'$L(ORNATR) ORNATR="X" ;Rejected
    145         S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
    146         D STATUS^ORCSAVE2(ORIFN,13)
    147 UD      ; -- Unable to discontinue [ack]
    148         N DA S DA=+$P(ORIFN,";",2) I DA D
    149         . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected
    150         . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
    151         Q
    152         ;
    153 OD      ; -- Discontinued
    154         S:$G(DGPMT) ORDUZ="" ;auto-dc on movement
    155         S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
    156         D UPDATE(1,"DC")
    157         Q
    158         ;
    159 DR      ; -- Discontinued [ack]
    160         D STATUS^ORCSAVE2(ORIFN,1)
    161         Q
    162         ;
    163 UPDATE(ORSTS,ORACT)     ; -- continue processing
    164         N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
    165         S ORX=$$CREATE^ORX1(ORNATR) D:ORX
    166         . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
    167         . I ORDA'>0 S ORERR="Cannot create new order action" Q
    168         . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
    169         . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
    170         . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
    171         . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
    172         I 'ORX D  ;no new action created
    173         . ;I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q
    174         . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only
    175         I ORACT="DC" D CANCEL^ORCSEND(+ORIFN) S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0
    176         Q
    177         ;
    178 RL      ;Release hold --entire section added with patch 110
    179         S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ  ;Set release hold date/time and release hold user
    180         S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist
    181         I $G(ORSTS)="" S ORSTS=6
    182         D UPDATE(ORSTS,"RL")
    183         Q
     1ORMRA ; SLC/MKB - Process Radiology ORM msgs ;2/21/02  15:44 [3/4/04 10:43am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228**;Dec 17, 1997
     3 ;DBIA 2968 allows for reading ^DIC(34
     4EN ; -- entry point for RA messages
     5 I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
     6 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
     7 S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2))
     8 S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12)
     9 D @ORDCNTRL
     10 Q
     11 ;
     12ZP ; -- Purged
     13 Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))  K ^OR(100,+ORIFN,4)
     14 ; - Set status=lapsed, if still active
     15 I "^3^5^6^8^"[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14)
     16 Q
     17 ;
     18ZR ; -- Purged as requested [ack]
     19 D DELETE^ORCSAVE2(+ORIFN)
     20 Q
     21 ;
     22ZU ; -- Unable to purge [ack]
     23 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
     24 Q
     25 ;
     26OK ; -- Order accepted, RA order # assigned [ack]
     27 N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending
     28 ; Ck if also scheduled, else quit
     29 S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ
     30 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
     31 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
     32OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
     33 ;Save the Radiology pre-certification Account Reference in the PV1
     34 ;segment of the HL7 message from the Radiology package to the Order
     35 ;File (#100). Support for Patch OR*3.0*228
     36 D PRECERT^ORWPFSS2
     37 Q
     38 ;
     39XX ; -- Change order
     40 N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S"
     41 D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)  S ORIFN=+ORIFN
     42 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
     43 I ORDA'>0 S ORERR="Cannot create new order action" Q
     44 ; -Update sts of order to active, last action to dc/edit:
     45 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7)
     46 S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12
     47 S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6)
     48 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
     49 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
     50 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
     51 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
     52 ; -Update responses, get/save new order text:
     53 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
     54 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
     55 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     56 Q
     57 ;
     58SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
     59 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
     60 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
     61 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
     62 I '$G(ORL) S ORERR="Missing or invalid patient location" Q
     63 D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)
     64SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J)
     65 I '$G(ORIFN) S ORERR="Cannot create new order" Q
     66 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
     67 D BDOSTR^ORWDBA3
     68 ;Save the Rediology pre-certification Account Reference in the PV1
     69 ;segment of the HL7 message from the Radiology package to the Order
     70 ;File (#100). Support for Patch OR*3.0*228
     71 D PRECERT^ORWPFSS2
     72 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
     73 D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN
     74 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
     75 Q
     76 ;
     77DLG ; -- Build ORDIALOG() from msg
     78 N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE
     79 S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0))
     80 D GETDLG1^ORCD(ORDIALOG)
     81 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
     82 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
     83 S ORDIALOG($$PTR("URGENCY"),1)=ORURG
     84 S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12)
     85D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
     86 S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5))
     87 I 'OI S ORERR="Invalid procedure" Q
     88 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
     89 S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type
     90 S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D
     91 . F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y
     92 S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31)
     93 S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC
     94 S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE))
     95 I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments
     96D2 ; might the procedure be scheduled at this point ??  Not in spec
     97 S CH=$$PTR("WORD PROCESSING 1"),CHI=0
     98 S OBX=OBR F  S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0  S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC"  Q:J="MSH"  I J="OBX" D
     99 . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6)
     100 . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2))
     101 . I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q
     102 . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q
     103 . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q
     104 . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q
     105 . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE
     106 S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)"
     107 Q
     108 ;
     109PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
     110 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
     111 ;
     112SC ; -- Status changed (scheduled, registered, or unverified)
     113 N ORSTS,OBR,OR3 ;110
     114 S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110
     115 G:ORSTS=6 SCQ ;136  Done if active, else get scheduled data
     116 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
     117 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
     118 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
     119 I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release.  Added with 110
     120SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
     121 Q
     122 ;
     123RE ; -- Completed, w/results
     124 N I,SEG,OBX
     125 D STATUS^ORCSAVE2(ORIFN,2)
     126 S OBX="" D  ;get Results D/T [from OBR]
     127 . N DA,DR,DIE,X,Y,OBR
     128 . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X=""
     129 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
     130 . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE
     131 S I=+ORC F  S I=$O(@ORMSG@(I)) Q:I<1  S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC"  I $E(SEG,1,3)="OBX" S OBX=I_U_SEG Q  ;first one
     132 S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"")
     133 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
     134 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
     135 Q
     136 ;
     137OH ; -- Held
     138 D UPDATE(3,"HD")
     139 Q
     140 ;
     141OC ; -- Cancelled/Unable to accept [ack]
     142UA ; -- Unable to accept [ack]
     143 S:'$L(ORNATR) ORNATR="X" ;Rejected
     144 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
     145 D STATUS^ORCSAVE2(ORIFN,13)
     146UD ; -- Unable to discontinue [ack]
     147 N DA S DA=+$P(ORIFN,";",2) I DA D
     148 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected
     149 . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
     150 Q
     151 ;
     152OD ; -- Discontinued
     153 S:$G(DGPMT) ORDUZ="" ;auto-dc on movement
     154 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
     155 D UPDATE(1,"DC")
     156 Q
     157 ;
     158DR ; -- Discontinued [ack]
     159 D STATUS^ORCSAVE2(ORIFN,1)
     160 Q
     161 ;
     162UPDATE(ORSTS,ORACT) ; -- continue processing
     163 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
     164 S ORX=$$CREATE^ORX1(ORNATR) D:ORX
     165 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
     166 . I ORDA'>0 S ORERR="Cannot create new order action" Q
     167 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
     168 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
     169 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
     170 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
     171 I 'ORX D  ;no new action created
     172 . I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q
     173 . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only
     174 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
     175 Q
     176 ;
     177RL ;Release hold --entire section added with patch 110
     178 S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ  ;Set release hold date/time and release hold user
     179 S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist
     180 I $G(ORSTS)="" S ORSTS=6
     181 D UPDATE(ORSTS,"RL")
     182 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIM02.m

    r613 r623  
    1 ORMTIM02        ; JM/SLC-ISC - PERFORM MISC TIME BASED ACTIVITIES ;05/02/06
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**253,243**;Dec 17, 1997;Build 242
    3         ;
    4         Q
    5 MISC    ; Perform misc time based activities
    6         ;
    7         D UNSIGNED ; Generate alerts for unsigned orders that have slipped through the cracks
    8         D INIT^ORWGTASK(0) ; check to run rebuild of cache for graphing
    9         ;
    10         Q
    11         ;
    12 UNSIGNED        ; Generate alerts for unsigned orders that were not alerted by CPRS
    13         ; This happens when CPRS crashes - through network connection drops or other causes
    14         N ORZPAT,ORZDATE,ORZIEN,ORZSUB,ORZSDATE,%DT,X,Y,ORZTIME,ORZNOW,ORZPURGE
    15         N ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORZREC8,ORZSIGDT,ORZSTS,ORZWHEN,ORMARKID
    16         N MINTIME,XTMPDAYS,XTMPHOUR,MINDAYS
    17         S ORN=12,ORMARKID="ORMTIME_UNSGNORD"
    18         ;
    19         S MINTIME=60 ; Order must be unsigned for 60 Minutes before generating an alert
    20         S MINDAYS=90 ; Order must have been generated within the last 90 days
    21         ;
    22         S XTMPDAYS=10 ; Keep ^XTMP record for 10 days - reset timeframe with each run
    23         S XTMPHOUR=48 ; Each order that's verified as having generated an alert has a flag set in
    24         ;               ^XTMP that's kept for 48 hours.  When flag is gone, must recheck alert status
    25         ;
    26         S X="T-"_MINDAYS
    27         D ^%DT S ORZSDATE=9999999-Y
    28         S %DT="ST",X="NOW" D ^%DT
    29         S ORZNOW=Y
    30         S ORZTIME=$$FMADD^XLFDT(ORZNOW,0,0,-MINTIME,0) ; Order must have existed for ORZTIME minutes
    31         S ORZPURGE=$$FMADD^XLFDT(ORZNOW,XTMPDAYS,0,0,0) ; Purge all marked flags if not run in XTMPDAYS days
    32         S ^XTMP(ORMARKID,0)=ORZPURGE_U_ORZNOW_U_"Unsigned Orders Reviewed by ORMTIME"
    33         S ORZPURGE=$$FMADD^XLFDT(ORZNOW,0,XTMPHOUR,0,0) ; Purge each marked flag XTMPHOUR hours after creation
    34         K MINTIME,MINDAYS,XTMPDAYS,XTMPHOUR,X,Y,%DT ; Kill non-namespaced vars
    35         S ORZPAT="" F  S ORZPAT=$O(^OR(100,"AS",ORZPAT)) Q:'ORZPAT  D
    36         . Q:$P(^DPT(+ORZPAT,0),U,21)  ; Quit if test patient
    37         . S ORZDATE=0 F  S ORZDATE=$O(^OR(100,"AS",ORZPAT,ORZDATE)) Q:'ORZDATE  I ORZDATE<ORZSDATE D
    38         . . S ORZIEN=0 F  S ORZIEN=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN)) Q:'ORZIEN  D
    39         . . . S ORZSUB=0 F  S ORZSUB=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN,ORZSUB)) Q:'ORZSUB  D
    40         . . . . I $D(^OR(100,ORZIEN,8,ORZSUB,0)) D
    41         . . . . . S ORZREC8=^OR(100,ORZIEN,8,ORZSUB,0)
    42         . . . . . S ORZSIGDT=$P(ORZREC8,U,6) I $L(ORZSIGDT)>0 Q  ; Can't have a sign date/time
    43         . . . . . S ORZSTS=$P(ORZREC8,U,4) I ORZSTS'=2 Q  ; must be in an unsigned state
    44         . . . . . S ORZWHEN=$P(ORZREC8,U) I ORZWHEN>ORZTIME Q  ; must have been unsigned for MINTIME
    45         . . . . . S ORBDFN=+ORZPAT
    46         . . . . . S ORNUM=ORZIEN_";"_ORZSUB
    47         . . . . . I $$NEEDALRT($P(ORZREC8,U,3),ORBDFN,ORNUM) D  ; must not have already generated an alert
    48         . . . . . . S (ORBADUZ,ORBPMSG,ORBPDATA)=""
    49         . . . . . . D DOALERT^ORB3
    50         . . . . . . D MARK(ORNUM) ; Alert sent, don't send another one
    51         D CLEAN
    52         Q
    53         ;
    54 NEEDALRT(PROVIDER,DFN,ORNUM)    ; Returns true if order needs an alert
    55         ;
    56         I $$MARKED(ORNUM) Q 0 ; If already checked, return
    57         ;
    58         N RESULT,SUROGATE
    59         S RESULT=1
    60         I $$HASALERT(PROVIDER,DFN) S RESULT=0 I 1
    61         E  D
    62         . S SUROGATE=$P($$GETSURO^XQALSURO(PROVIDER),U,1)
    63         . I +SUROGATE,$$HASALERT(SUROGATE,DFN) S RESULT=0
    64         I 'RESULT D MARK(ORNUM)
    65         Q RESULT
    66         ;
    67 HASALERT(USER,PATIENT)  ; Returns true if alert exists for user and patient
    68         N RESULT,ALERTID,DATE
    69         S RESULT=0,ALERTID="OR,"_PATIENT_",12"
    70         I $D(^XTV(8992,"AXQAN",ALERTID,USER)) D  ;DBIA# 2689
    71         . S DATE=$O(^XTV(8992,"AXQAN",ALERTID,USER,0))
    72         . I $G(DATE)>0 S RESULT=1
    73         Q RESULT
    74         ;
    75 MARKED(ORNUM)   ; Returns true if the order has been marked as not needing an alert
    76         I $D(^XTMP(ORMARKID,"A",ORNUM))>0 Q 1
    77         Q 0
    78         ;
    79 MARK(ORNUM)     ; Marks an order as already having been alerted
    80         S ^XTMP(ORMARKID,"A",ORNUM)=""
    81         S ^XTMP(ORMARKID,"B",ORZPURGE,ORNUM)=""
    82         Q
    83 CLEAN   ; Clean up old entries in ^XTMP
    84         N IDX,ORNUM
    85         S IDX=0
    86         F  S IDX=$O(^XTMP(ORMARKID,"B",IDX)) Q:((+IDX=0)!(IDX>ORZNOW))  D
    87         . S ORNUM=0
    88         . F  S ORNUM=$O(^XTMP(ORMARKID,"B",IDX,ORNUM)) Q:+ORNUM=0  D
    89         . . K ^XTMP(ORMARKID,"A",ORNUM)
    90         . . K ^XTMP(ORMARKID,"B",IDX,ORNUM)
    91         Q
     1ORMTIM02 ; JM/SLC-ISC - PERFORM MISC TIME BASED ACTIVITIES ;05/02/06
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**253**;Dec 17, 1997
     3 ;
     4 Q
     5MISC ; Perform misc time based activities
     6 ;
     7 D UNSIGNED ; Generate alerts for unsigned orders that have slipped through the cracks
     8 ;
     9 Q
     10 ;
     11UNSIGNED ; Generate alerts for unsigned orders that were not alerted by CPRS
     12 ; This happens when CPRS crashes - through network connection drops or other causes
     13 N ORZPAT,ORZDATE,ORZIEN,ORZSUB,ORZSDATE,%DT,X,Y,ORZTIME,ORZNOW,ORZPURGE
     14 N ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORZREC8,ORZSIGDT,ORZSTS,ORZWHEN,ORMARKID
     15 N MINTIME,XTMPDAYS,XTMPHOUR,MINDAYS
     16 S ORN=12,ORMARKID="ORMTIME_UNSGNORD"
     17 ;
     18 S MINTIME=60 ; Order must be unsigned for 60 Minutes before generating an alert
     19 S MINDAYS=90 ; Order must have been generated within the last 90 days
     20 ;
     21 S XTMPDAYS=10 ; Keep ^XTMP record for 10 days - reset timeframe with each run
     22 S XTMPHOUR=48 ; Each order that's verified as having generated an alert has a flag set in
     23 ;               ^XTMP that's kept for 48 hours.  When flag is gone, must recheck alert status
     24 ;
     25 S X="T-"_MINDAYS
     26 D ^%DT S ORZSDATE=9999999-Y
     27 S %DT="ST",X="NOW" D ^%DT
     28 S ORZNOW=Y
     29 S ORZTIME=$$FMADD^XLFDT(ORZNOW,0,0,-MINTIME,0) ; Order must have existed for ORZTIME minutes
     30 S ORZPURGE=$$FMADD^XLFDT(ORZNOW,XTMPDAYS,0,0,0) ; Purge all marked flags if not run in XTMPDAYS days
     31 S ^XTMP(ORMARKID,0)=ORZPURGE_U_ORZNOW_U_"Unsigned Orders Reviewed by ORMTIME"
     32 S ORZPURGE=$$FMADD^XLFDT(ORZNOW,0,XTMPHOUR,0,0) ; Purge each marked flag XTMPHOUR hours after creation
     33 K MINTIME,MINDAYS,XTMPDAYS,XTMPHOUR,X,Y,%DT ; Kill non-namespaced vars
     34 S ORZPAT="" F  S ORZPAT=$O(^OR(100,"AS",ORZPAT)) Q:'ORZPAT  D
     35 . Q:$P(^DPT(+ORZPAT,0),U,21)  ; Quit if test patient
     36 . S ORZDATE=0 F  S ORZDATE=$O(^OR(100,"AS",ORZPAT,ORZDATE)) Q:'ORZDATE  I ORZDATE<ORZSDATE D
     37 . . S ORZIEN=0 F  S ORZIEN=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN)) Q:'ORZIEN  D
     38 . . . S ORZSUB=0 F  S ORZSUB=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN,ORZSUB)) Q:'ORZSUB  D
     39 . . . . I $D(^OR(100,ORZIEN,8,ORZSUB,0)) D
     40 . . . . . S ORZREC8=^OR(100,ORZIEN,8,ORZSUB,0)
     41 . . . . . S ORZSIGDT=$P(ORZREC8,U,6) I $L(ORZSIGDT)>0 Q  ; Can't have a sign date/time
     42 . . . . . S ORZSTS=$P(ORZREC8,U,4) I ORZSTS'=2 Q  ; must be in an unsigned state
     43 . . . . . S ORZWHEN=$P(ORZREC8,U) I ORZWHEN>ORZTIME Q  ; must have been unsigned for MINTIME
     44 . . . . . S ORBDFN=+ORZPAT
     45 . . . . . S ORNUM=ORZIEN_";"_ORZSUB
     46 . . . . . I $$NEEDALRT($P(ORZREC8,U,3),ORBDFN,ORNUM) D  ; must not have already generated an alert
     47 . . . . . . S (ORBADUZ,ORBPMSG,ORBPDATA)=""
     48 . . . . . . D DOALERT^ORB3
     49 . . . . . . D MARK(ORNUM) ; Alert sent, don't send another one
     50 D CLEAN
     51 Q
     52 ;
     53NEEDALRT(PROVIDER,DFN,ORNUM) ; Returns true if order needs an alert
     54 ;
     55 I $$MARKED(ORNUM) Q 0 ; If already checked, return
     56 ;
     57 N RESULT,SUROGATE
     58 S RESULT=1
     59 I $$HASALERT(PROVIDER,DFN) S RESULT=0 I 1
     60 E  D
     61 . S SUROGATE=$P($$GETSURO^XQALSURO(PROVIDER),U,1)
     62 . I +SUROGATE,$$HASALERT(SUROGATE,DFN) S RESULT=0
     63 I 'RESULT D MARK(ORNUM)
     64 Q RESULT
     65 ;
     66HASALERT(USER,PATIENT) ; Returns true if alert exists for user and patient
     67 N RESULT,ALERTID,DATE
     68 S RESULT=0,ALERTID="OR,"_PATIENT_",12"
     69 I $D(^XTV(8992,"AXQAN",ALERTID,USER)) D  ;DBIA# 2689
     70 . S DATE=$O(^XTV(8992,"AXQAN",ALERTID,USER,0))
     71 . I $G(DATE)>0 S RESULT=1
     72 Q RESULT
     73 ;
     74MARKED(ORNUM) ; Returns true if the order has been marked as not needing an alert
     75 I $D(^XTMP(ORMARKID,"A",ORNUM))>0 Q 1
     76 Q 0
     77 ;
     78MARK(ORNUM) ; Marks an order as already having been alerted
     79 S ^XTMP(ORMARKID,"A",ORNUM)=""
     80 S ^XTMP(ORMARKID,"B",ORZPURGE,ORNUM)=""
     81 Q
     82CLEAN ; Clean up old entries in ^XTMP
     83 N IDX,ORNUM
     84 S IDX=0
     85 F  S IDX=$O(^XTMP(ORMARKID,"B",IDX)) Q:((+IDX=0)!(IDX>ORZNOW))  D
     86 . S ORNUM=0
     87 . F  S ORNUM=$O(^XTMP(ORMARKID,"B",IDX,ORNUM)) Q:+ORNUM=0  D
     88 . . K ^XTMP(ORMARKID,"A",ORNUM)
     89 . . K ^XTMP(ORMARKID,"B",IDX,ORNUM)
     90 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIME.m

    r613 r623  
    1 ORMTIME ; SLC/RJS - PROCESS TIME BASED EVENT ;9/29/99  09:35 [2/1/00 9:30am]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**40,253,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN      ; Main entry tag.
    5         ;
    6         N OCXPSDT,OCXZTSK,OCXERR,OCXORMTR,OCXSTDT,OCXLOCK,OCXPAR
    7         K ^TMP("OCXORMTIME",$J)
    8         S OCXLOCK=0
    9         S OCXORMTR="ORMTIME: Startup"
    10         S OCXSTDT=$$EDATE($$IDATE("NOW"))
    11         S ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Attempting to lock ^OR(100,""AE"") at "_OCXSTDT_"."
    12         L +^OR(100,"AE"):10
    13         I  D
    14         .S OCXLOCK=1
    15         .D SCAN
    16         .L -^OR(100,"AE")
    17         .K ^TMP("OCXORMTIME")
    18         .S OCXPAR=$$IDATE2("NOW")
    19         .D PUT^XPAR("SYS","ORM ORMTIME LAST RUN",1,OCXPAR,.OCXERR)
    20         S:'OCXLOCK ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Unable to lock ^OR(100,""AE"") at "_OCXSTDT_" attempt."
    21         Q
    22         ;
    23 SCAN    ; Call ORMTIM01 for order checking, etc.  ORMTIM02 for misc time based tasks
    24         ;
    25         D SCAN^ORMTIM01
    26         D MISC^ORMTIM02
    27         D TASK^ORTSKLPS
    28         Q
    29         ;
    30 EDATE(Y)        X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
    31         ;
    32 IDATE(X)        N %DT,Y S %DT="F" D ^%DT Q Y
    33         ;
    34 IDATE2(X)       N %DT,Y S %DT="TF" D ^%DT Q Y
    35         ;
    36 REQUEUE(ORMQT)  ; Code formerly queued ORMTIME tasks in Taskman.
    37         ;
    38         ; (This tag kept for compatibility with outside calls.)
    39         ;
    40         Q
    41         ;
    42 STATUS  ; Check status of last ORMTIME run.
    43         ;
    44         N ORMLAST
    45         ;
    46         ; Get date/time of last ORMTIME run:
    47         S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I")
    48         S ORMLAST=$$EDATE(ORMLAST) ; Convert to external format for display.
    49         ;
    50         ; Present information to user:
    51         W !
    52         W !,"     ORMTIME last ran "_ORMLAST_"."
    53         W !
    54         ;
    55         Q
    56         ;
    57 BULL    ; Send a bulletin if ORMTIME's last run is greater than 24 hours.
    58         ;
    59         N DIC,ORMMSG,X,XMSUB,XMTEXT,XMY,XMZ,Y,ORMLAST
    60         ;
    61         ; Don't send bulletin if ORMTIME STATUS mail group does not exist:
    62         S DIC=3.8,DIC(0)="",X="ORMTIME STATUS"
    63         D ^DIC Q:(+Y<0)
    64         ;
    65         S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I")
    66         I $$FMDIFF^XLFDT($$IDATE2("NOW"),ORMLAST,2)>86400  D
    67         .S XMY("G.ORMTIME STATUS")=""
    68         .S XMSUB=" ORMTIME Warning"
    69         .S ORMMSG(1,0)=" "
    70         .S ORMMSG(2,0)="    The ORMTIME process last ran more than 24 hours ago. "
    71         .S ORMMSG(3,0)=" "
    72         .S ORMMSG(4,0)=" The ORMTIME background job handles activating and expiring orders,"
    73         .S ORMMSG(5,0)=" some time based notifications, as well as purging of temporary CPRS"
    74         .S ORMMSG(6,0)=" data. It is important that it runs regularly."
    75         .S ORMMSG(7,0)=" "
    76         .S ORMMSG(8,0)="    Assure that the scheduled option, ORMTIME RUN, is correctly implemented."
    77         .S ORMMSG(9,0)=" "
    78         .S XMTEXT="ORMMSG("
    79         .D ^XMD
    80         Q
    81         ;
     1ORMTIME ; SLC/RJS - PROCESS TIME BASED EVENT ;9/29/99  09:35 [2/1/00 9:30am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**40,253**;Dec 17, 1997
     3 ;
     4EN ; Main entry tag.
     5 ;
     6 N OCXPSDT,OCXZTSK,OCXERR,OCXORMTR,OCXSTDT,OCXLOCK,OCXPAR
     7 K ^TMP("OCXORMTIME",$J)
     8 S OCXLOCK=0
     9 S OCXORMTR="ORMTIME: Startup"
     10 S OCXSTDT=$$EDATE($$IDATE("NOW"))
     11 S ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Attempting to lock ^OR(100,""AE"") at "_OCXSTDT_"."
     12 L +^OR(100,"AE"):10
     13 I  D
     14 .S OCXLOCK=1
     15 .D SCAN
     16 .L -^OR(100,"AE")
     17 .K ^TMP("OCXORMTIME")
     18 .S OCXPAR=$$IDATE2("NOW")
     19 .D PUT^XPAR("SYS","ORM ORMTIME LAST RUN",1,OCXPAR,.OCXERR)
     20 S:'OCXLOCK ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Unable to lock ^OR(100,""AE"") at "_OCXSTDT_" attempt."
     21 Q
     22 ;
     23SCAN ; Call ORMTIM01 for order checking, etc.  ORMTIM02 for misc time based tasks
     24 ;
     25 D SCAN^ORMTIM01
     26 D MISC^ORMTIM02
     27 Q
     28 ;
     29EDATE(Y) X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
     30 ;
     31IDATE(X) N %DT,Y S %DT="F" D ^%DT Q Y
     32 ;
     33IDATE2(X) N %DT,Y S %DT="TF" D ^%DT Q Y
     34 ;
     35REQUEUE(ORMQT) ; Code formerly queued ORMTIME tasks in Taskman.
     36 ;
     37 ; (This tag kept for compatibility with outside calls.)
     38 ;
     39 Q
     40 ;
     41STATUS ; Check status of last ORMTIME run.
     42 ;
     43 N ORMLAST
     44 ;
     45 ; Get date/time of last ORMTIME run:
     46 S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I")
     47 S ORMLAST=$$EDATE(ORMLAST) ; Convert to external format for display.
     48 ;
     49 ; Present information to user:
     50 W !
     51 W !,"     ORMTIME last ran "_ORMLAST_"."
     52 W !
     53 ;
     54 Q
     55 ;
     56BULL ; Send a bulletin if ORMTIME's last run is greater than 24 hours.
     57 ;
     58 N DIC,ORMMSG,X,XMSUB,XMTEXT,XMY,XMZ,Y,ORMLAST
     59 ;
     60 ; Don't send bulletin if ORMTIME STATUS mail group does not exist:
     61 S DIC=3.8,DIC(0)="",X="ORMTIME STATUS"
     62 D ^DIC Q:(+Y<0)
     63 ;
     64 S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I")
     65 I $$FMDIFF^XLFDT($$IDATE2("NOW"),ORMLAST,2)>86400  D
     66 .S XMY("G.ORMTIME STATUS")=""
     67 .S XMSUB=" ORMTIME Warning"
     68 .S ORMMSG(1,0)=" "
     69 .S ORMMSG(2,0)="    The ORMTIME process last ran more than 24 hours ago. "
     70 .S ORMMSG(3,0)=" "
     71 .S ORMMSG(4,0)=" The ORMTIME background job handles activating and expiring orders,"
     72 .S ORMMSG(5,0)=" some time based notifications, as well as purging of temporary CPRS"
     73 .S ORMMSG(6,0)=" data. It is important that it runs regularly."
     74 .S ORMMSG(7,0)=" "
     75 .S ORMMSG(8,0)="    Assure that the scheduled option, ORMTIME RUN, is correctly implemented."
     76 .S ORMMSG(9,0)=" "
     77 .S XMTEXT="ORMMSG("
     78 .D ^XMD
     79 Q
     80 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRF.m

    r613 r623  
    1 ORPRF   ;SLC/JLI-Patient record flag ;6/14/06
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 FMT(ROOT)       ; Format - Convert record flag data to displayable data
    5         ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags
    6         N IDX,IX,CNT
    7         S (IDX,CNT)=0
    8         F  S IDX=$O(ROOT(IDX)) Q:'IDX  D
    9         . S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2)
    10         . S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2)
    11         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name:               "_$P($G(ROOT(IDX,"FLAG")),U,2)
    12         . I $D(ROOT(IDX,"NARR")) D
    13         . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="            "
    14         . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative:   "
    15         . . S IX=0 F  S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX  D
    16         . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0))
    17         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="            "
    18         . ; -- Assignment Details:
    19         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type:               "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2)
    20         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category:           "_$P($G(ROOT(IDX,"CATEGORY")),U,2)
    21         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status:       "_"Active"
    22         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date:   "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2)
    23         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by:             "_$P($G(ROOT(IDX,"APPRVBY")),U,2)
    24         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date:        "_$P($G(ROOT(IDX,"REVIEWDT")),U,2)
    25         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site:              "_$P($G(ROOT(IDX,"OWNER")),U,2)
    26         . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site:        "_$P($G(ROOT(IDX,"ORIGSITE")),U,2)
    27         K ROOT
    28         Q
    29         ;
    30 HASFLG(ORY,PTDFN)       ;Does patient PTDFN has flags
    31         ;     DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA)
    32         ; Returns array ORY listing active assigned flags
    33         ; Array ORY has form:
    34         ;   ORY(flagID) = flagID^flagname,CAT1
    35         ;      where CAT1 is 1 if flag is cat 1, 0 if cat 2
    36         ; ORY = Num of items returned in array ORY = num of flags
    37         I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q
    38         N IDY,PRFARR,CAT1
    39         K ^TMP("ORPRF",$J)
    40         S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
    41         Q:'ORY
    42         D FMT(.@("PRFARR")) ; Sets ^TMP("ORPRF"
    43         S IDY=0 F  S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY  D
    44         . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG"))
    45         . S CAT1=0
    46         . I $G(^TMP("ORPRF",$J,IDY,"CATEGORY"))="I (NATIONAL)" S CAT1=1
    47         . S ORY(IDY)=ORY(IDY)_U_CAT1
    48         Q
    49         ;
    50 HASFLG1(ORY,PTDFN)      ; Does patient PTDFN have **Cat I** flags
    51         ; Returns array ORY listing active assigned Cat I flags
    52         ; Array ORY has form:
    53         ;   ORY(flagID) = flagID^flagname
    54         ; ORY = Num of Cat I flags
    55         ;   If pt has no Cat I flags ORY = 0 and no flags are returned.
    56         ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags
    57         ; 
    58         I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q
    59         N FLAGID,PRFARR,CAT1CNT,ACTFLGS
    60         K ^TMP("ORPRF",$J)
    61         S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
    62         I 'ACTFLGS S ORY=0 Q
    63         S (FLAGID,CAT1CNT)=0
    64         F  S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID  D
    65         . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q
    66         . K PRFARR(FLAGID)
    67         I 'CAT1CNT S ORY=0 Q
    68         D FMT(.@("PRFARR"))
    69         S IDY=0 F  S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY  D
    70         . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG"))
    71         S ORY=CAT1CNT
    72         Q
    73         ;
    74 HASCAT1(HASCAT1,PTDFN)  ;Does patient have Category I flags (no arrays)
    75         ; Returns boolean HASCAT1 = 0 or 1
    76         ; Does NOT set arrays or TMP globals
    77         N FLAGID,PRFARR,ACTFLGS
    78         S (HASCAT1,FLAGID)=0
    79         S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X
    80         F  S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID  D  Q:HASCAT1
    81         . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1
    82 HASCAT1X        ;
    83         Q
    84         ;
    85 TRIGRPOP(POPUP,PTDFN)   ;Should the flag display pop up upon patient selection
    86         ; for patient PTDFN?
    87         ;As of 1/10/06, returns POPUP as:
    88         ;   1 if pt has any active flags, either Cat I or Cat II
    89         ;   0 otherwise
    90         N PRFARR
    91         S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0)
    92         Q
    93         ;
    94 GETFLG(ORY,PTDFN,FLAGID)        ;Return detailed flag info for flag FLAGID
    95         I '$D(^TMP("ORPRF",$J,FLAGID)) Q
    96         N IX,CNT
    97         S (IX,CNT)=0
    98         F  S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX  D
    99         . S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX))
    100         Q
    101         ;
    102 CLEAR(ORY)      ;Clear up the temp global
    103         K ^TMP("ORPRF",$J)
    104         Q
    105         ;
     1ORPRF ;SLC/JLI-Patient record flag ;1/10/06
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215**;Dec 17, 1997
     3 ;
     4FMT(ROOT) ; Format - Convert record flag data to displayable data
     5 ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags
     6 N IDX,IX,CNT
     7 S (IDX,CNT)=0
     8 F  S IDX=$O(ROOT(IDX)) Q:'IDX  D
     9 . S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2)
     10 . S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2)
     11 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name:               "_$P($G(ROOT(IDX,"FLAG")),U,2)
     12 . I $D(ROOT(IDX,"NARR")) D
     13 . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="            "
     14 . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative:   "
     15 . . S IX=0 F  S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX  D
     16 . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0))
     17 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="            "
     18 . ; -- Assignment Details:
     19 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type:               "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2)
     20 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category:           "_$P($G(ROOT(IDX,"CATEGORY")),U,2)
     21 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status:       "_"Active"
     22 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date:   "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2)
     23 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by:             "_$P($G(ROOT(IDX,"APPRVBY")),U,2)
     24 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date:        "_$P($G(ROOT(IDX,"REVIEWDT")),U,2)
     25 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site:              "_$P($G(ROOT(IDX,"OWNER")),U,2)
     26 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site:        "_$P($G(ROOT(IDX,"ORIGSITE")),U,2)
     27 K ROOT
     28 Q
     29 ;
     30HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags
     31 ;     DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA)
     32 ; Returns array ORY listing active assigned flags
     33 ; Array ORY has form:
     34 ;   ORY(flagID) = flagID^flagname
     35 ; ORY = Num of items returned in array ORY = num of flags
     36 I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q
     37 N IDY,PRFARR
     38 K ^TMP("ORPRF",$J)
     39 S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
     40 Q:'ORY
     41 D FMT(.@("PRFARR")) ; Sets ^TMP("ORPRF"
     42 S IDY=0 F  S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY  D
     43 . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG"))
     44 Q
     45 ;
     46HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags
     47 ; Returns array ORY listing active assigned Cat I flags
     48 ; Array ORY has form:
     49 ;   ORY(flagID) = flagID^flagname
     50 ; ORY = Num of Cat I flags
     51 ;   If pt has no Cat I flags ORY = 0 and no flags are returned.
     52 ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags
     53 ; 
     54 I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q
     55 N FLAGID,PRFARR,CAT1CNT,ACTFLGS
     56 K ^TMP("ORPRF",$J)
     57 S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
     58 I 'ACTFLGS S ORY=0 Q
     59 S (FLAGID,CAT1CNT)=0
     60 F  S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID  D
     61 . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q
     62 . K PRFARR(FLAGID)
     63 I 'CAT1CNT S ORY=0 Q
     64 D FMT(.@("PRFARR"))
     65 S IDY=0 F  S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY  D
     66 . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG"))
     67 S ORY=CAT1CNT
     68 Q
     69 ;
     70HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays)
     71 ; Returns boolean HASCAT1 = 0 or 1
     72 ; Does NOT set arrays or TMP globals
     73 N FLAGID,PRFARR,ACTFLGS
     74 S (HASCAT1,FLAGID)=0
     75 S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X
     76 F  S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID  D  Q:HASCAT1
     77 . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1
     78HASCAT1X ;
     79 Q
     80 ;
     81TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection
     82 ; for patient PTDFN?
     83 ;As of 1/10/06, returns POPUP as:
     84 ;   1 if pt has any active flags, either Cat I or Cat II
     85 ;   0 otherwise
     86 N PRFARR
     87 S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0)
     88 Q
     89 ;
     90GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID
     91 I '$D(^TMP("ORPRF",$J,FLAGID)) Q
     92 N IX,CNT
     93 S (IX,CNT)=0
     94 F  S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX  D
     95 . S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX))
     96 Q
     97 ;
     98CLEAR(ORY) ;Clear up the temp global
     99 K ^TMP("ORPRF",$J)
     100 Q
     101 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRPM.m

    r613 r623  
    1 ORPRPM  ;DAN/SLC Performance Measure; ;4/8/04  10:20
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**107,114,119,196,190,243**;Dec 17, 1997;Build 242
    3         ;
    4         ;DBIA SECTION
    5         ;4195 - EN^PSOTPCUL
    6         ;
    7         ;This routine will print a report indicating the percent of
    8         ;orders entered for a provider by a provider holding the ORES key.
    9         ;The data for the report will be stored in ^TMP as follows:
    10         ;^TMP($J,"SUM",Provider Name,Patient Status)=Total # of order (universe)^Denominator^Numerator^Verbal^Written^Telephone^Policy^Electronically entered^Student entered^Outpatient narcotic orders
    11         ;Where Patient Status is I for inpatient or O for outpatient.
    12         ;
    13         N DIR,ORSD,ORED,ORPROV,ORTYPE,ORPT,ORREP,ORPIECE,Y,DIRUT,DUOUT,DTOUT,ZTRTN,ORDT,ORIEN,ORACT0,ORPVID,PG,REPDT,ORSTOP,ORI,ORJ,ORPAT,ORTOT,ORSTOT,X,ORPVNM,ORORD,ORPTST,ORP,ORWROTE,ORNS,ORFS,ORPFILE
    14         D GETDATE K DIR Q:$D(DIRUT)  ;quit if no dates selected ;get start and end dates
    15         D GETPROV K DIR Q:'$D(ORPROV)!($G(ORPROV)'="ALL"&($D(ORPROV)'=11))!($D(DUOUT))!($D(DTOUT))  ;quit if user didn't select all providers or if didn't choose individual providers or if user timed out or up-arrowed out
    16         D GETOTHER Q:$D(DIRUT)  ;quit if any questions were unanswered in this section
    17         I DUZ=1395 D DQ Q
    18         S ZTRTN="DQ^ORPRPM" D QUE^ORUTL1(ZTRTN,"CPRS Performance Monitor")
    19         Q
    20         ;
    21 GETDATE ;Prompt for start and end dates
    22         S DIR(0)="DO^:DT:AE",DIR("A")="Enter starting date",DIR("?")="Enter date to begin searching from" D ^DIR Q:$D(DIRUT)  S ORSD=Y
    23         S DIR(0)="DOA^"_ORSD_":DT:AE",DIR("A")="Enter ending date: ",DIR("?")="Enter date to stop searching.  Must be between "_$$FMTE^XLFDT(ORSD,2)_" and "_$$FMTE^XLFDT(DT,2) D ^DIR Q:$D(DIRUT)
    24         S ORED=Y_.24,ORSD=ORSD-.1 ;Set end date to end of day, start date back to include current day
    25         Q  ;End GETDATE
    26         ;
    27 GETPROV ;Allow selection of all/single/multiple providers
    28         ;return ORPROV="ALL" for all providers or ORPROV array for individual providers
    29         S DIR(0)="Y",DIR("A")="Do you want ALL providers to appear on this report",DIR("B")="Y",DIR("?")="Enter Yes to search for all providers.  Enter No to select individual providers"  D ^DIR Q:$D(DIRUT)  S ORPROV=$S(Y=1:"ALL",1:"") Q:ORPROV="ALL"
    30         K DIR ;clear DIR variables before getting individual providers
    31         F  D  Q:$D(DIRUT)  ;quit when finished selecting
    32         .S DIR(0)="PO^200:AEQM",DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",DIR("A")="Select "_$S($D(ORPROV)=11:"another ",1:"")_"provider"
    33         .S DIR("?")="Select providers to appear on report.  Return when finished, ^ to stop processing" D ^DIR Q:$D(DIRUT)  S ORPROV(+Y)=""
    34         Q  ;End GETPROV
    35         ;
    36 GETOTHER        ;Get order type, patient type, and summary only report response
    37         ;Get order type first
    38         S DIR(0)="S^A:All orders;P:Pharmacy orders only",DIR("A")="Select order category",DIR("B")="P",DIR("?")="Enter P to see pharmacy orders only.  Enter A to see all orders. Enter ^ to quit" D ^DIR Q:$D(DIRUT)  S ORTYPE=Y
    39         K DIR
    40         ;Get patient status
    41         S DIR(0)="S^I:Inpatient;O:Outpatient;B:Both",DIR("A")="Select patient status",DIR("B")="B",DIR("?")="Enter patient status at time of order.  Enter ^ to quit" D ^DIR Q:$D(DIRUT)  S ORPT=Y
    42         K DIR
    43         ;Ask if user desires facility subtotal, summary, detail, or both (detail and summary) reports
    44         S DIR(0)="S^S:Summary (includes provider details);D:Detail (includes order details);B:Both (Summary & Detail);T:Summary Report Totals Only (no provider details)",DIR("A")="Select report",DIR("B")="S"
    45         D ^DIR Q:$D(DIRUT)  S ORREP=Y,ORFS=0 I Y="T" S ORREP="S",ORFS=1
    46         K DIR
    47         Q  ;End GETOTHER
    48         ;
    49 DQ      ;Come here to do build and print from QUE^ORUTL either direct or tasked
    50         U IO K ^TMP($J) ;clean out temp space
    51         S ORDT=ORSD F  S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>ORED)  S ORIEN="" F  S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN  I $O(^OR(100,"AF",ORDT,ORIEN,0))=1 I $D(^OR(100,ORIEN,8,1,0)) D CHECK
    52         D PRINT^ORPRPM1
    53         K ^TMP($J)
    54         Q
    55         ;
    56 CHECK   ;If order matches requirements then save
    57         S ORPFILE=$P($G(^OR(100,ORIEN,0)),"^",2) Q:ORPFILE=""  ;Quit if no object of order
    58         I $P(ORPFILE,";",2)["DPT" Q:$P($G(^DPT(+$P($G(^OR(100,ORIEN,0)),"^",2),0)),"^",21)  ;Quit if test patient
    59         Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0  ;190 quit if order type not standard
    60         S ORPTST=$P($G(^OR(100,ORIEN,0)),"^",12) ;patient status (in/out)
    61         I ORPT'="B" Q:ORPTST'=ORPT  ;Quit if patient status is not 'both' and status doesn't match selected status
    62         S ORNS=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14))
    63         I ORTYPE'="A"&(ORNS'="PS") Q  ;if not getting all types of orders then quit if order is not from pharmacy
    64         I ORPTST="O",ORNS="PS",$G(^OR(100,ORIEN,4))=+$G(^OR(100,ORIEN,4)),$L($T(EN^PSOTPCUL)) Q:$$EN^PSOTPCUL($G(^OR(100,ORIEN,4)))  ;196 Don't count if outpatient pharm order is a transitional pharmacy benefit order
    65         S ORACT0=$G(^OR(100,ORIEN,8,1,0)),ORORD=$P(ORACT0,"^",12) ;ORORD holds nature of order ien
    66         S ORPVID=$P(ORACT0,"^",3) I ORPROV'="ALL" Q:'$D(ORPROV(ORPVID))  ;quit if ordering provider doesn't match user selected provider
    67         S ORPVNM=$P($G(^VA(200,ORPVID,0)),"^") ;get provider name
    68         Q:'$D(^XUSEC("ORES",ORPVID))  ;quit if ordering provider doesn't have ORES key DBIA # 10076 allows direct read of XUSEC
    69         Q:"^1^2^3^5^8^"'[("^"_ORORD_"^")  ;quit if NATURE OF ORDER is not verbal, written, telephoned, policy, or electronically entered
    70         D COUNT ;Count order
    71         Q
    72         ;
    73 COUNT   ;This section determines how the order should be counted
    74         N OREB,ORPIECE
    75         D ADD(1) ;Add one to universe (total # of orders)
    76         S OREB=$P(ORACT0,"^",13) ;Entered by
    77         S ^TMP($J,"DET",ORPVNM,ORIEN)=$D(^XUSEC("ORES",OREB))&(OREB=ORPVID) ;Mark "HAS ORES" column for detailed listing if entered by = provider and has ORES key
    78         I OREB=ORPVID D ADD(2),ADD(3) Q  ;if order entered by provider then add one to denominator and numerator
    79         I ORNS="PS" I $$OIDEA=1 D ADD(10) Q  ;If order requires wet signature add one to narcotic group
    80         I $$STUDENT D ADD(9) Q  ;If order entered by student add one to student group
    81         S ORPIECE=$S(ORORD=1:4,ORORD=2:5,ORORD=3:6,ORORD=8:7,1:8) D ADD(ORPIECE) ;add to exceptions group for orders not entered by provider
    82         I ORORD'=5 D ADD(2) ;Add to denominator if not policy order
    83         Q
    84         ;
    85 ADD(PIECE)      ;Add one to storage
    86         S $P(^TMP($J,"SUM",ORPVNM,ORPTST),"^",PIECE)=$P($G(^TMP($J,"SUM",ORPVNM,ORPTST)),"^",PIECE)+1 Q
    87         ;
    88 OIDEA() ;Check to see if pharmacy order requires wet signature
    89         ;dbia 3373 allows call to pharmacy API or dbia 221 allows direct read of ^PSDRUG if routine doesn't exist yet
    90         N OI,PSOI,SIGREQ,PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX
    91         Q:ORPTST'="O" 0 ;quit if inpatient
    92         S OI=$$VALUE^ORX8(ORIEN,"ORDERABLE") ;get orderable item
    93         S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) I PSOI'>0 Q 0 ;quit if no pharmacy orderable item
    94         I $L($T(OIDEA^PSSUTLA1)) S SIGREQ=$$OIDEA^PSSUTLA1(PSOI,"O") Q:SIGREQ=1 1 Q 0 ;If SIGREQ = 1 then wet signature required
    95         S (PSSXOLPD,PSSXNODD)=0
    96         S PSSPKLX=0
    97         K ^TMP($J,"ORPRPM ASP")
    98         D ASP^PSS50(PSOI,,,"ORPRPM ASP")
    99         F PSSXOLP=0:0 S PSSXOLP=$O(^TMP($J,"ORPRPM ASP","")) Q:'PSSXOLP!(PSSXOLPD=1)  D
    100         .K ^TMP($J,"ORPRPM DATA") D DATA^PSS50(PSSXOLP,,(DT-1),,,"ORPRPM DATA") I +^TMP($J,"ORPRPM DATA",0)<0 Q
    101         .I 'PSSPKLX,$G(^TMP($J,"ORPRPM DATA",63))'["O" K ^TMP($J,"ORPRPM DATA") Q
    102         .I PSSPKLX I $G(^TMP($J,"ORPRPM DATA",63))'["U",$G(^TMP($J,"ORPRPM DATA",63))'["I" Q
    103         .S PSSXNODD=1
    104         .S PSSXOLPX=$G(^TMP($J,"ORPRPM DATA",3))
    105         .I PSSXOLPX[1!(PSSXOLPX[2)!((PSSXOLPX[3)&(PSSXOLPX["A")) S PSSXOLPD=1 Q
    106         .I PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5) S PSSXOLPD=2
    107         I PSSXOLPD=0,'PSSXNODD S PSSXOLPD=""
    108         K ^TMP($J,"ORPRPM ASP")
    109         K ^TMP($J,"ORPRPM DATA")
    110         Q PSSXOLPD
    111         ;
    112 STUDENT()       ;Check to see if entered by is a student
    113         ;Check USER CLASS for membership in "STUDENT" CLASS - DBIA 2324
    114         ;Then check PROVIDER CLASS in NEW PERSON file for "STUDENT" - DBIA 10060
    115         N ORCLASS,ORSUB,EXPIRE,ORUSR
    116         D WHATIS^USRLM(OREB,"ORCLASS") ;API to get user class membership
    117         S ORSUB=0,ORUSR=0 F  S ORSUB=$O(ORCLASS(ORSUB)) Q:ORSUB=""!ORUSR  D
    118         .I $$UP^XLFSTR(ORSUB)'["STUDENT" Q  ;User not a member of student class
    119         .I ORDT'<+$P(ORCLASS(ORSUB),"^",4) S EXPIRE=$S(+$P(ORCLASS(ORSUB),"^",5):$P(ORCLASS(ORSUB),"^",5),1:9999999) I ORDT'>EXPIRE S ORUSR=1 ;member of student class and within date range for class
    120         I ORUSR Q 1 ;User identified as a student
    121         K ORCLASS
    122         S DIC=200,DR=53.5,DA=OREB,DIQ="ORCLASS",DIQ(0)="E" D EN^DIQ1
    123         I $G(ORCLASS(200,OREB,53.5,"E"))["STUDENT" Q 1 ;Provider class set to student
    124         Q 0 ;User not a student
     1ORPRPM ;DAN/SLC Performance Measure; ;10/7/04  09:08
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**107,114,119,196,190,225**;Dec 17, 1997
     3 ;
     4 ;DBIA SECTION
     5 ;4195 - EN^PSOTPCUL
     6 ;3744 - $$TESTPAT^VADPT
     7 ;10060- Reference to file 200
     8 ;
     9 ;This routine will print a report indicating the percent of
     10 ;orders entered for a provider by a provider holding the ORES key.
     11 ;The data for the report will be stored in ^TMP as follows:
     12 ;^TMP($J,"SUM",Provider Name,Patient Status)=Total # of order (universe)^Denominator^Numerator^Verbal^Written^Telephone^Policy^Electronically entered^Student entered^Outpatient narcotic orders
     13 ;Where Patient Status is I for inpatient or O for outpatient.
     14 ;
     15 N DIR,ORSD,ORED,ORPROV,ORTYPE,ORPT,ORREP,ORPIECE,Y,DIRUT,DUOUT,DTOUT,ZTRTN,ORDT,ORIEN,ORACT0,ORPVID,PG,REPDT,ORSTOP,ORI,ORJ,ORPAT,ORTOT,ORSTOT,X,ORPVNM,ORORD,ORPTST,ORP,ORWROTE,ORNS,ORFS,ORPFILE
     16 D GETDATE K DIR Q:$D(DIRUT)  ;quit if no dates selected ;get start and end dates
     17 D GETPROV K DIR Q:'$D(ORPROV)!($G(ORPROV)'="ALL"&($D(ORPROV)'=11))!($D(DUOUT))!($D(DTOUT))  ;quit if user didn't select all providers or if didn't choose individual providers or if user timed out or up-arrowed out
     18 D GETOTHER Q:$D(DIRUT)  ;quit if any questions were unanswered in this section
     19 S ZTRTN="DQ^ORPRPM" D QUE^ORUTL1(ZTRTN,"CPRS Performance Monitor")
     20 Q
     21 ;
     22GETDATE ;Prompt for start and end dates
     23 S DIR(0)="DO^:DT:AE",DIR("A")="Enter starting date",DIR("?")="Enter date to begin searching from" D ^DIR Q:$D(DIRUT)  S ORSD=Y
     24 S DIR(0)="DOA^"_ORSD_":DT:AE",DIR("A")="Enter ending date: ",DIR("?")="Enter date to stop searching.  Must be between "_$$FMTE^XLFDT(ORSD,2)_" and "_$$FMTE^XLFDT(DT,2) D ^DIR Q:$D(DIRUT)
     25 S ORED=Y_.24,ORSD=ORSD-.1 ;Set end date to end of day, start date back to include current day
     26 Q  ;End GETDATE
     27 ;
     28GETPROV ;Allow selection of all/single/multiple providers
     29 ;return ORPROV="ALL" for all providers or ORPROV array for individual providers
     30 S DIR(0)="Y",DIR("A")="Do you want ALL providers to appear on this report",DIR("B")="Y",DIR("?")="Enter Yes to search for all providers.  Enter No to select individual providers"  D ^DIR Q:$D(DIRUT)  S ORPROV=$S(Y=1:"ALL",1:"") Q:ORPROV="ALL"
     31 K DIR ;clear DIR variables before getting individual providers
     32 F  D  Q:$D(DIRUT)  ;quit when finished selecting
     33 .S DIR(0)="PO^200:AEQM",DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",DIR("A")="Select "_$S($D(ORPROV)=11:"another ",1:"")_"provider"
     34 .S DIR("?")="Select providers to appear on report.  Return when finished, ^ to stop processing" D ^DIR Q:$D(DIRUT)  S ORPROV(+Y)=""
     35 Q  ;End GETPROV
     36 ;
     37GETOTHER ;Get order type, patient type, and summary only report response
     38 ;Get order type first
     39 S DIR(0)="S^A:All orders;P:Pharmacy orders only",DIR("A")="Select order category",DIR("B")="P",DIR("?")="Enter P to see pharmacy orders only.  Enter A to see all orders. Enter ^ to quit" D ^DIR Q:$D(DIRUT)  S ORTYPE=Y
     40 K DIR
     41 ;Get patient status
     42 S DIR(0)="S^I:Inpatient;O:Outpatient;B:Both",DIR("A")="Select patient status",DIR("B")="B",DIR("?")="Enter patient status at time of order.  Enter ^ to quit" D ^DIR Q:$D(DIRUT)  S ORPT=Y
     43 K DIR
     44 ;Ask if user desires facility subtotal, summary, detail, or both (detail and summary) reports
     45 S DIR(0)="S^S:Summary (includes provider details);D:Detail (includes order details);B:Both (Summary & Detail);T:Summary Report Totals Only (no provider details)",DIR("A")="Select report",DIR("B")="S"
     46 D ^DIR Q:$D(DIRUT)  S ORREP=Y,ORFS=0 I Y="T" S ORREP="S",ORFS=1
     47 K DIR
     48 Q  ;End GETOTHER
     49 ;
     50DQ ;Come here to do build and print from QUE^ORUTL either direct or tasked
     51 U IO K ^TMP($J) ;clean out temp space
     52 S ORDT=ORSD F  S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>ORED)  S ORIEN="" F  S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN  I $O(^OR(100,"AF",ORDT,ORIEN,0))=1 I $D(^OR(100,ORIEN,8,1,0)) D CHECK
     53 D PRINT^ORPRPM1
     54 K ^TMP($J)
     55 Q
     56 ;
     57CHECK ;If order matches requirements then save
     58 S ORPFILE=$P($G(^OR(100,ORIEN,0)),"^",2) Q:ORPFILE=""  ;Quit if no object of order
     59 I $P(ORPFILE,";",2)["DPT" Q:$$TESTPAT^VADPT(+$P($G(^OR(100,ORIEN,0)),"^",2))  ;225 Quit if test patient
     60 Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0  ;190 quit if order type not standard
     61 Q:$P(^ORD(100.98,$P(^OR(100,ORIEN,0),U,11),0),U)="NON-VA MEDICATIONS"  ;225 Quit if Non-VA med entry
     62 S ORPTST=$P($G(^OR(100,ORIEN,0)),"^",12) ;patient status (in/out)
     63 I ORPT'="B" Q:ORPTST'=ORPT  ;Quit if patient status is not 'both' and status doesn't match selected status
     64 S ORNS=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14))
     65 I ORTYPE'="A"&(ORNS'="PS") Q  ;if not getting all types of orders then quit if order is not from pharmacy
     66 I ORPTST="O",ORNS="PS",$G(^OR(100,ORIEN,4))=+$G(^OR(100,ORIEN,4)),$L($T(EN^PSOTPCUL)) Q:$$EN^PSOTPCUL($G(^OR(100,ORIEN,4)))  ;196 Don't count if outpatient pharm order is a transitional pharmacy benefit order
     67 S ORACT0=$G(^OR(100,ORIEN,8,1,0)),ORORD=$P(ORACT0,"^",12) ;ORORD holds nature of order ien
     68 S ORPVID=$P(ORACT0,"^",3) I ORPROV'="ALL" Q:'$D(ORPROV(ORPVID))  ;quit if ordering provider doesn't match user selected provider
     69 S ORPVNM=$$GET1^DIQ(200,ORPVID_",",.01) ;225 get provider name
     70 Q:'$D(^XUSEC("ORES",ORPVID))  ;quit if ordering provider doesn't have ORES key DBIA # 10076 allows direct read of XUSEC
     71 Q:"^1^2^3^5^8^"'[("^"_ORORD_"^")  ;quit if NATURE OF ORDER is not verbal, written, telephoned, policy, or electronically entered
     72 D COUNT ;Count order
     73 Q
     74 ;
     75COUNT ;This section determines how the order should be counted
     76 N OREB,ORPIECE
     77 D ADD(1) ;Add one to universe (total # of orders)
     78 S OREB=$P(ORACT0,"^",13) ;Entered by
     79 S ^TMP($J,"DET",ORPVNM,ORIEN)=$D(^XUSEC("ORES",OREB))&(OREB=ORPVID) ;Mark "HAS ORES" column for detailed listing if entered by = provider and has ORES key
     80 I OREB=ORPVID D ADD(2),ADD(3) Q  ;if order entered by provider then add one to denominator and numerator
     81 I ORNS="PS" I $$OIDEA=1 D ADD(10) Q  ;If order requires wet signature add one to narcotic group
     82 I $$STUDENT D ADD(9) Q  ;If order entered by student add one to student group
     83 S ORPIECE=$S(ORORD=1:4,ORORD=2:5,ORORD=3:6,ORORD=8:7,1:8) D ADD(ORPIECE) ;add to exceptions group for orders not entered by provider
     84 I ORORD'=5 D ADD(2) ;Add to denominator if not policy order
     85 Q
     86 ;
     87ADD(PIECE) ;Add one to storage
     88 S $P(^TMP($J,"SUM",ORPVNM,ORPTST),"^",PIECE)=$P($G(^TMP($J,"SUM",ORPVNM,ORPTST)),"^",PIECE)+1 Q
     89 ;
     90OIDEA() ;Check to see if pharmacy order requires wet signature
     91 ;dbia 3373 allows call to pharmacy API or dbia 221 allows direct read of ^PSDRUG if routine doesn't exist yet
     92 N OI,PSOI,SIGREQ,PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX
     93 Q:ORPTST'="O" 0 ;quit if inpatient
     94 S OI=$$VALUE^ORX8(ORIEN,"ORDERABLE") ;get orderable item
     95 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) I PSOI'>0 Q 0 ;quit if no pharmacy orderable item
     96 I $L($T(OIDEA^PSSUTLA1)) S SIGREQ=$$OIDEA^PSSUTLA1(PSOI,"O") Q:SIGREQ=1 1 Q 0 ;If SIGREQ = 1 then wet signature required
     97 S (PSSXOLPD,PSSXNODD)=0
     98 S PSSPKLX=0
     99 F PSSXOLP=0:0 S PSSXOLP=$O(^PSDRUG("ASP",PSOI,PSSXOLP)) Q:'PSSXOLP!(PSSXOLPD=1)  D
     100 .I $P($G(^PSDRUG(PSSXOLP,"I")),"^"),$P($G(^("I")),"^")<DT Q
     101 .I 'PSSPKLX,$P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["O" Q
     102 .I PSSPKLX I $P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["U",$P($G(^(2)),"^",3)'["I" Q
     103 .S PSSXNODD=1
     104 .S PSSXOLPX=$P($G(^PSDRUG(PSSXOLP,0)),"^",3)
     105 .I PSSXOLPX[1!(PSSXOLPX[2)!((PSSXOLPX[3)&(PSSXOLPX["A")) S PSSXOLPD=1 Q
     106 .I PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5) S PSSXOLPD=2
     107 I PSSXOLPD=0,'PSSXNODD S PSSXOLPD=""
     108 Q PSSXOLPD
     109 ;
     110STUDENT() ;Check to see if entered by is a student
     111 ;Check USER CLASS for membership in "STUDENT" CLASS - DBIA 2324
     112 ;Then check PROVIDER CLASS in NEW PERSON file for "STUDENT" - DBIA 10060
     113 N ORCLASS,ORSUB,EXPIRE,ORUSR
     114 D WHATIS^USRLM(OREB,"ORCLASS") ;API to get user class membership
     115 S ORSUB=0,ORUSR=0 F  S ORSUB=$O(ORCLASS(ORSUB)) Q:ORSUB=""!ORUSR  D
     116 .I $$UP^XLFSTR(ORSUB)'["STUDENT" Q  ;User not a member of student class
     117 .I ORDT'<+$P(ORCLASS(ORSUB),"^",4) S EXPIRE=$S(+$P(ORCLASS(ORSUB),"^",5):$P(ORCLASS(ORSUB),"^",5),1:9999999) I ORDT'>EXPIRE S ORUSR=1 ;member of student class and within date range for class
     118 I ORUSR Q 1 ;User identified as a student
     119 K ORCLASS
     120 S DIC=200,DR=53.5,DA=OREB,DIQ="ORCLASS",DIQ(0)="E" D EN^DIQ1
     121 I $G(ORCLASS(200,OREB,53.5,"E"))["STUDENT" Q 1 ;Provider class set to student
     122 Q 0 ;User not a student

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRS07.m

    r613 r623  
    1 ORPRS07 ; slc/dcm - Managing multiple reportz ;6/10/97  15:43
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**281**;Dec 17, 1997;Build 14
    3 EN      ;Entry point
    4         N ORVP
    5         D MAIN("")
    6         Q
    7 MAIN(ORVP)      ; Controls branching
    8         N DFN,DIC,GMTYP,I,ORANSI,ORDG,OREND,ORH,ORH2,ORPRES,ORSCPAT,ORSDG
    9         N ORSHORT,ORSRI,ORSRPT,ORSSTOP,ORSSTRT,ORTIT,ORWHL,VAROOT,XQORSPEW,X,Y
    10         N ORAGE,ORATTEND,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
    11         N ORSDG,ORURMBD,ORX,ORCONT,OROPREF
    12         I '+$G(ORVP) D P^ORPRS01 Q:$D(ORSCPAT)'>9
    13         S ORANSI=0,XQORFLG("SH")=1
    14         S (ORANSI,OREND,X)=0
    15         I +$G(ORSCPAT)=1,+$G(ORSCPAT(1)) S ORVP=+$G(ORSCPAT(1))_";DPT(",Y=+ORVP D HOMO^ORUDPA
    16         S DIC=101 S X="ORS REPORT MENU" D EN^XQOR
    17         K VA200,VAERR,VAIN,VADM
    18         Q
    19 EXIT    ; Queue output
    20         N DUOUT,ORSRI,ORSRPT,ZTDESC,ZTRTN,ZTSAVE S OREND=+$G(OREND)
    21         S ORSRI=0 F  S ORSRI=$O(Y(ORSRI)) Q:ORSRI'>0  S ORSRPT=ORSRI,ORSRPT(ORSRI)=Y(ORSRI)
    22         I $S($D(XQORPOP):1,$G(OREND)=1:1,$D(DUOUT):1,$D(DIROUT):1,'$D(ORSRPT):1,'$D(ORSCPAT)&'+$G(ORVP):1,1:0) Q
    23         S (ZTSAVE("OR*"),ZTSAVE("GM*"),ZTSAVE("LR*"))="",IO("Q")=1
    24         S ZTRTN="OUTPUT^ORPRS07",ZTDESC="Results Reporting" W ! D DEVICE
    25         Q
    26 OUTPUT  ; Loops through ORSRPT( and queues each report
    27         N DIROUT,DIRUT,ORH,ORH2,ORMETHOD,ORSEND,ORSHORT,ORSI,ORSJ,ORSRI,ORTIT,ORWHL,X
    28         N XQORNOD,XQORSPEW,XY,ORSLTR,ORSPNM,ORDG,ORION S ORION=$G(ION)
    29         I +$G(ORVP) D REPORT(ORVP) K OROLOC,ORSSTOP,ORSSTRT,VAROOT,VA,X1 Q
    30         S ORSI=0 F  S ORSI=$O(ORSCPAT(ORSI)) Q:ORSI'>0!($G(DIROUT))!($$S^%ZTLOAD)  S:'$O(ORSCPAT(ORSI)) ORSEND=1  D
    31         . S ORVP=+ORSCPAT(ORSI)_";DPT(",ORSPNM=$P(ORSCPAT(ORSI),U,2)
    32         . D REPORT(ORVP)
    33         K ORNO,ORSPG
    34         Q
    35 REPORT(ORVP)    ; Loops through ORSRPT( and prints all reports for ea patient
    36         N ORSJ,ORSSTFLG,XQORNOD
    37         U IO
    38         S ORSJ=0 F  S ORSJ=$O(ORSRPT(ORSJ)) Q:ORSJ'>0!+$G(DIROUT)!$G(OREND)  D
    39         . S XQORNOD=$P(ORSRPT(ORSJ),U,2)_";ORD(101,",ORMETHOD=$G(^ORD(101,+XQORNOD,101.05,20,1))
    40         . I $D(ORSSTRT)>9,+XQORNOD S ORSSTRT=+$G(ORSSTRT(+XQORNOD)),ORH=$P($G(ORSSTRT(+XQORNOD)),U,2)
    41         . I $D(ORSSTOP)>9,+XQORNOD S ORSSTOP=+$G(ORSSTOP(+XQORNOD)),ORH2=$P($G(ORSSTOP(+XQORNOD)),U,2)
    42         . I $D(ORSDG(+XQORNOD)) S ORDG=$G(ORSDG(+XQORNOD))
    43         . I $L(ORMETHOD) X ORMETHOD I $G(ION)'=ORION S IOP=ORION D ^%ZIS
    44         . I +$G(ORSSTFLG) D STOP^ORPRS01 S ORSSTFLG=0
    45         Q
    46 DEVICE  ; Device Handling/Output control
    47         N IO,IOP,%ZIS
    48         S %ZIS="Q",%ZIS("B")="HOME" D ^%ZIS Q:POP
    49         I +$G(ORSRPT)>1,(IO'=IO(0)),'$D(IO("Q")) W !,"Printing of multiple reports requires queueing.",!
    50         D @$S(+$G(ORSRPT)>1&(IO'=IO(0)):"QUE",$D(IO("Q")):"QUE",1:"NOQUE")
    51         Q
    52 QUE     ; Set ZT parameters and tasks ZTRTN
    53         N ZTIO K IO("Q")
    54         S ZTIO=ION
    55         D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
    56         K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D ^%ZISC
    57         Q
    58 NOQUE   ; Calls ZTRTN in interactive mode
    59         I IO'=IO(0) U IO
    60         D @ZTRTN
    61         D ^%ZISC
    62         Q
     1ORPRS07 ; slc/dcm - Managing multiple reportz ;6/10/97  15:43
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
     3EN ;Entry point
     4 N ORVP
     5 D MAIN("")
     6 Q
     7MAIN(ORVP) ; Controls branching
     8 N DFN,DIC,GMTYP,I,ORANSI,ORDG,OREND,ORH,ORH2,ORPRES,ORSCPAT,ORSDG
     9 N ORSHORT,ORSRI,ORSRPT,ORSSTOP,ORSSTRT,ORTIT,ORWHL,VAROOT,XQORSPEW,X,Y
     10 N ORAGE,ORATTEND,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
     11 N ORSDG,ORURMBD,ORX,ORCONT,OROPREF
     12 I '+$G(ORVP) D P^ORPRS01 Q:$D(ORSCPAT)'>9
     13 S ORANSI=0,XQORFLG("SH")=1
     14 S (ORANSI,OREND,X)=0
     15 I +$G(ORSCPAT)=1,+$G(ORSCPAT(1)) S ORVP=+$G(ORSCPAT(1))_";DPT(",Y=+ORVP D HOMO^ORUDPA
     16 S DIC=101 S X="ORS REPORT MENU" D EN^XQOR
     17 K VA200,VAERR,VAIN,VADM
     18 Q
     19EXIT ; Queue output
     20 N DUOUT,ORSRI,ORSRPT,ZTDESC,ZTRTN,ZTSAVE S OREND=+$G(OREND)
     21 S ORSRI=0 F  S ORSRI=$O(Y(ORSRI)) Q:ORSRI'>0  S ORSRPT=ORSRI,ORSRPT(ORSRI)=Y(ORSRI)
     22 I $S($D(XQORPOP):1,$G(OREND)=1:1,$D(DUOUT):1,$D(DIROUT):1,'$D(ORSRPT):1,'$D(ORSCPAT)&'+$G(ORVP):1,1:0) Q
     23 S (ZTSAVE("OR*"),ZTSAVE("GM*"),ZTSAVE("LR*"))="",IO("Q")=1
     24 S ZTRTN="OUTPUT^ORPRS07",ZTDESC="Results Reporting" W ! D DEVICE
     25 Q
     26OUTPUT ; Loops through ORSRPT( and queues each report
     27 N DIROUT,DIRUT,ORH,ORH2,ORMETHOD,ORSEND,ORSHORT,ORSI,ORSJ,ORSRI,ORTIT,ORWHL,X
     28 N XQORNOD,XQORSPEW,XY,ORSLTR,ORSPNM,ORDG,ORION S ORION=$G(ION)
     29 I +$G(ORVP) D REPORT(ORVP) K OROLOC,ORSSTOP,ORSSTRT,VAROOT,VA,X1 Q
     30 S ORSI=0 F  S ORSI=$O(ORSCPAT(ORSI)) Q:ORSI'>0!($G(DIROUT))!($$S^%ZTLOAD)  S:'$O(ORSCPAT(ORSI)) ORSEND=1  D
     31 . S ORVP=+ORSCPAT(ORSI)_";DPT(",ORSPNM=$P(ORSCPAT(ORSI),U,2)
     32 . D REPORT(ORVP)
     33 K ORNO,ORSPG
     34 Q
     35REPORT(ORVP) ; Loops through ORSRPT( and prints all reports for ea patient
     36 N ORSJ,ORSSTFLG,XQORNOD
     37 U IO
     38 S ORSJ=0 F  S ORSJ=$O(ORSRPT(ORSJ)) Q:ORSJ'>0!+$G(DIROUT)!$G(OREND)  D
     39 . S XQORNOD=$P(ORSRPT(ORSJ),U,2),ORMETHOD=$G(^ORD(101,+XQORNOD,101.05,20,1))
     40 . I $D(ORSSTRT)>9,+XQORNOD S ORSSTRT=+$G(ORSSTRT(XQORNOD)),ORH=$P($G(ORSSTRT(XQORNOD)),U,2)
     41 . I $D(ORSSTOP)>9,+XQORNOD S ORSSTOP=+$G(ORSSTOP(XQORNOD)),ORH2=$P($G(ORSSTOP(XQORNOD)),U,2)
     42 . I $D(ORSDG(+XQORNOD)) S ORDG=$G(ORSDG(+XQORNOD))
     43 . I $L(ORMETHOD) X ORMETHOD I $G(ION)'=ORION S IOP=ORION D ^%ZIS
     44 . I +$G(ORSSTFLG) D STOP^ORPRS01 S ORSSTFLG=0
     45 Q
     46DEVICE ; Device Handling/Output control
     47 N IO,IOP,%ZIS
     48 S %ZIS="Q",%ZIS("B")="HOME" D ^%ZIS Q:POP
     49 I +$G(ORSRPT)>1,(IO'=IO(0)),'$D(IO("Q")) W !,"Printing of multiple reports requires queueing.",!
     50 D @$S(+$G(ORSRPT)>1&(IO'=IO(0)):"QUE",$D(IO("Q")):"QUE",1:"NOQUE")
     51 Q
     52QUE ; Set ZT parameters and tasks ZTRTN
     53 N ZTIO K IO("Q")
     54 S ZTIO=ION
     55 D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
     56 K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D ^%ZISC
     57 Q
     58NOQUE ; Calls ZTRTN in interactive mode
     59 I IO'=IO(0) U IO
     60 D @ZTRTN
     61 D ^%ZISC
     62 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ11.m

    r613 r623  
    1 ORQ11   ;slc/dcm-Get patient orders in context ;3/31/04  09:57
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,78,99,94,148,141,177,186,190,195,215,243**;Dec 17, 1997;Build 242
    3 LOOP    ; -- main loop through "ACT" x-ref
    4         I $G(XREF)="AW" D AW Q
    5         I $G(FLG)=27 D EXPD^ORQ12 Q
    6         K ^TMP("ORGOTIT",$J)
    7 AWIN    ;Jump in here to add active orders to AW context
    8         N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195
    9         S NOW=+$E($$NOW^XLFDT,1,12),TM=SDATE
    10         F  S TM=$O(^OR(100,"ACT",PAT,TM)) Q:'TM!(TM>EDATE)  S TO=0 F  S TO=$O(^OR(100,"ACT",PAT,TM,TO)) Q:'TO  I $D(ORGRP(TO)) D
    11         . S IFN=0 F  S IFN=$O(^OR(100,"ACT",PAT,TM,TO,IFN)) Q:'IFN  I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT),$D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
    12         .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"ACT",PAT,TM,TO,IFN,ACTOR)) Q:ACTOR<1  I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13!(FLG=1) S X8=^(0),X7=$G(^(7)) D LP1
    13         S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
    14         Q
    15 AW      ; -- loop through "AW" x-ref
    16         K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J)
    17         N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195
    18         S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE
    19         F  S TO=$O(^OR(100,"AW",PAT,TO)) Q:'TO  I $D(ORGRP(TO)) S TM=EDATE F  S TM=$O(^OR(100,"AW",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE)  D
    20         . S IFN=0 F  S IFN=$O(^OR(100,"AW",PAT,TO,TM,IFN)) Q:'IFN  I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D
    21         .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)=""
    22         S TM=0 F  S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM  S TO=0 F  S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO  D
    23         . S IFN=0 F  S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN  I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
    24         .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1  I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1
    25         S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
    26         I +$$GET^XPAR("SYS","OR ORDER SUMMARY CONTEXT",1,"I")=2 S SDATE=9999999-SDATE,EDATE=9999999-EDATE D AWIN
    27         K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J)
    28         Q
    29 LP1     ; -- main secondary loop
    30         N STS ;195
    31         N TAG
    32         Q:$P(X3,U,8)  Q:$P(X3,U,3)=99  S STS=$P(X3,U,3)
    33         I '$G(GETKID),$P(X3,U,9),'$P($G(^OR(100,$P(X3,U,9),3)),U,8),FLG'=11 Q
    34         I $L($P(X0,U,17)),"^10^11^"[(U_STS_U) S X=$$LAPSED^OREVNTX($P(X0,U,17))
    35         S TAG=$S(FLG=2:"CUR1",FLG=4:"COM1",FLG=5:"EXG1",FLG=7:"PEN1",FLG=8:"UVR1",FLG=9:"UVN1",FLG=10:"UVC1",FLG=12:"FLG1",FLG=13:"VP1",FLG=14:"VPU1",FLG=18:"HLD1",FLG=20:"CHT1",FLG=21:"CHTSUM",FLG=22:"LPS1",FLG=23:"AVT1",1:"ALL1")
    36         I TAG="ALL1" S TAG=$S(FLG=3:"DC1",FLG=28:"DC1",1:"ALL1")
    37         D @TAG
    38         Q
    39         ; ** FLG context specific loops:
    40         ;
    41 ALL1    ; 1 -- secondary pass for All, Recent Orders, Unsigned
    42         D GET^ORQ12(IFN,ORLIST,DETAIL,$G(ACTOR))
    43         Q
    44         ;
    45 CUR     ; 2 -- Active/Current
    46         N X,X0,X1,X2,X3,X8,%H,YD,%,TM,IFN,ACTOR,NORX,OIEN,OACT
    47         I $G(GROUP)=$O(^ORD(100.98,"B","ALL SERVICES",0)),$G(ORWARD),$G(DGPMT)'=1 S NORX=$O(^ORD(100.98,"B","O RX",0)) ;K:X ORGRP(X) ; 177 screen out Outpt Meds if inpt
    48         S X2=+$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"I"),X=$H,X=+X*24+($P(X,",",2)/3600),X1=X-X2,X3=X1#24,X1=X1\24,X2=$J(X3*3600,0,0),%H=X1_","_X2 D YMD^%DTC S YD=+(X_%)
    49         S TM=SDATE F  S TM=$O(^OR(100,"AC",PAT,TM)) Q:TM<1!(TM>EDATE)  S IFN=0 F  S IFN=$O(^OR(100,"AC",PAT,TM,IFN)) Q:IFN<1  I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
    50         . Q:'$D(ORGRP($P(X0,U,11)))  S ACTOR=0
    51         . F  S ACTOR=$O(^OR(100,"AC",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  I $D(^OR(100,IFN,8,ACTOR,0)) S X8=^(0) D
    52         .. I "^10^12^"[(U_$P(X8,U,15)_U) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
    53         .. I $P(X8,U,15)=13,$P(X8,U)<YD K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
    54         .. I $P(X8,U,15)="",ACTOR'=$P(X3,U,7) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
    55         .. ;AGP waiting for approval change to remove duplicate orders for DC reason
    56         .. ;I ACTOR>0,$P($G(^OR(100,IFN,8,ACTOR,0)),U,2)="DC" S OIEN=IFN,OACT=ACTOR
    57         .. ;I OIEN=IFN,OACT>ACTOR K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
    58         .. D LP1
    59         S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
    60         Q
    61 CUR1    ; 2 -- secondary pass for Active/Current
    62         N STOP S STOP=$P(X0,U,9)
    63         I STS=10 K ^OR(100,"AC",PAT,TM,IFN) Q  ;no delayed orders
    64         I $P(X8,U,4)=2,$P(X8,U,15)=11 G CURX ;incl all unsig/unrel actions
    65         I '$D(YD),"^1^2^7^12^13^14^"[(U_STS_U) K ^OR(100,"AC",PAT,TM,IFN) Q
    66         I $D(YD),"^1^2^7^12^13^14^"[(U_STS_U),STOP<YD K ^OR(100,"AC",PAT,TM,IFN) Q
    67         I $G(NORX),NORX=$P(X0,U,11) Q  ;skip Rx for inpatients
    68 CURX    D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    69         Q
    70         ;
    71 DC1     ; 3 -- secondary pass for DC
    72         I FLG=28 D GETEIE^ORQ12(IFN,ORLIST,DETAIL,ACTOR) Q
    73         I STS=1!(STS=13)!(STS=12) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    74         Q
    75         ;
    76 COM1    ; 4 -- secondary pass for Completed/Expired
    77         N STOP S STOP=$P(X0,U,9)
    78         I STS=2!(STS=7)!($L(STOP)&(STOP<NOW)&(STS'=1)&(STS'=13)&(STS'=12)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    79         Q
    80         ;
    81 EXG     ; 5 -- Expiring
    82         N ORNG,ORDT,ORDW,ORHOL,X,Y,%DT,DIC,TMW,NOW ;195
    83         F ORNG=1:1 D  I ORHOL=0,ORDW=0 Q
    84         . S ORDT=$$FMADD^XLFDT(DT,ORNG),ORDW=$S($H-4+ORNG#7>4:1,1:0)
    85         . S DIC="^HOLIDAY(",X=$P(ORDT,".")
    86         . D ^DIC S ORHOL=$S(+$G(Y)>0:1,1:0)
    87         S %DT="",X="T+"_ORNG D ^%DT
    88         S TMW=Y_".9999",NOW=+$E($$NOW^XLFDT,1,12)
    89         D CUR ;D LOOP
    90         Q
    91 EXG1    ; 5 -- secondary pass for Expiring
    92         N STOP S STOP=$P(X0,U,9)
    93         I STS'=1,STS'=2,STS'=7,STS'>9,STOP>NOW,STOP'>TMW D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    94         Q
    95         ;
    96 ACT     ; 6 -- Recent Activity (Order Summary)
    97         ;N ORLSIGN S ORLSIGN=$$GET^XPAR("ALL","OR ORDER REVIEW DT","`"_+PAT,"Q")
    98         N TM,IFN,X0,X3,ACTOR,X8
    99         S TM=SDATE F  S TM=$O(^OR(100,"AR",PAT,TM)) Q:TM<1!(TM>EDATE)  D
    100         . S IFN=0 F  S IFN=$O(^OR(100,"AR",PAT,TM,IFN)) Q:IFN<1  S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) I $D(ORGRP(+$P(X0,U,11))) D
    101         .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"AR",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  I $D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0) D LP1
    102         S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
    103         Q
    104         ;
    105 PEN1    ; 7 -- secondary pass for Pending
    106         I STS=5 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    107         Q
    108         ;
    109 UVR1    ; 8 -- secondary pass for Unverified
    110         ;      Include if: unverified, released, inpt, not repl/canc/lapsed
    111         I '$P(X8,U,9),'$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    112         Q
    113         ;
    114 UVN1    ; 9 -- secondary pass for Unverified/Nurse
    115         ;      Include if: unverified, released, inpt, not repl/canc/lapsed
    116         I '$P(X8,U,9),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    117         Q
    118         ;
    119 UVC1    ; 10 -- secondary pass for Unverified/Clerk
    120         ;       Include if: unverified, released, inpt, not repl/canc/lapsed
    121         I '$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    122         Q
    123         ;
    124 INPT()  ; -- Returns 1 or 0, if inpt order using X0=^OR(100,IFN,0)
    125         I ($P(X0,U,12)="I")!($$TYPE^OREVNTX($P(X0,U,17))="D") Q 1
    126         ;I $P($G(^SC(+$P(X0,U,10),0)),U,3)="W" Q 1
    127         Q 0
    128         ;
    129 SIG     ; 11 -- Unsigned
    130         N TM,IFN,X0,X3,ACTOR S TM=SDATE
    131         F  S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE)  S IFN=0 F  S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1  D
    132         . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3))
    133         . I X0="" K ^OR(100,"AS",PAT,TM,IFN) Q  ;deleted
    134         . Q:'$D(ORGRP(+$P(X0,U,11)))  ;not a selected DispGrp
    135         . S ACTOR=0 F  S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  D
    136         .. I $P($G(^OR(100,IFN,8,ACTOR,0)),U,4)'=2 K ^OR(100,"AS",PAT,TM,IFN,ACTOR) Q  ;signed or deleted
    137         .. D LP1
    138         S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
    139         Q
    140         ;
    141 FLG1    ; 12 -- secondary pass for Flagged
    142         I +$G(^OR(100,IFN,8,ACTOR,3)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    143         Q
    144         ;
    145 VP1     ; 13 -- secondary pass for Verbal/Phone
    146         N ORNATR S ORNATR=$P(X8,U,12)
    147         I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12
    148         Q
    149         ;
    150 VPU1    ; 14 -- secondary pass for Verbal/Phone Unsigned
    151         N ORNATR S ORNATR=$P(X8,U,12)
    152         I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2),'$P(X8,U,5),$P(X8,U,4)=2 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12
    153         Q
    154         ;
    155 HLD1    ; 18 -- secondary pass for On Hold
    156         I STS=3 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    157         Q
    158         ;
    159 NEW     ; 19 -- New Orders, plus other unsigned orders by current provider
    160         N IFN,ACTOR,TM,X0,X3,X8,ORENT,ORPAR
    161         S IFN=0 F  S IFN=$O(^TMP("ORNEW",$J,IFN)) Q:IFN'>0  D  ;New orders
    162         . S ACTOR=0 F  S ACTOR=$O(^TMP("ORNEW",$J,IFN,ACTOR)) Q:ACTOR'>0  D
    163         .. Q:'$D(^OR(100,IFN,0))  Q:'$D(^(8,ACTOR,0))  ;deleted
    164         .. D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    165         G:'$D(^XUSEC("ORES",DUZ)) NW1 ;ck parameter for add'l orders
    166         S ORENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"")
    167         S ORPAR=$$GET^XPAR(ORENT,"OR UNSIGNED ORDERS ON EXIT")
    168         I ORPAR S TM=SDATE F  S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE)  D
    169         . S IFN=0 F  S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1  D
    170         .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  D
    171         ... Q:$D(^TMP("ORNEW",$J,IFN,ACTOR))  ;already included
    172         ... S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACTOR,0))
    173         ... I $S(ORPAR=1&($P(X8,U,3)=DUZ):1,ORPAR=2:1,1:0) D LP1
    174 NW1     S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
    175         Q
    176         ;
    177 CHT1    ; 20 -- secondary pass for Chart Review
    178         ;       Include if: unverified, released, inpt, not repl/canc/lapsed
    179         I '$P(X8,U,19),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    180         Q
    181         ;
    182 CHTSUM  ; 21 -- secondary pass for Chart copy summary
    183         ;       Included based on Nature of Order
    184         N XP,NAT
    185         S XP=+$$GET^XPAR("SYS","OR PRINT ALL ORDERS CHART SUM",1,"I")
    186         I XP=2 D  Q  ;depends on Nature of Order
    187         . S NAT=$P($G(^OR(100,IFN,6)),U)
    188         . I 'NAT S NAT=$P(X8,U,12)
    189         . I NAT,$$CHART^ORX1(NAT) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    190         I XP=0 D  Q  ;If original printed, print on sum
    191         . I X7 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    192         D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;XP=1 gets All orders
    193         Q
    194         ;
    195 LPS1    ; 22 -- secondary pass for Lapsed
    196         I STS=14 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    197         Q
    198         ;
    199 AVT1    ; 23 -- secondary pass for Active/Pending sts only
    200         I (STS=6)!(STS=5) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
    201         Q
    202         ;
    203 QUIT    ; -- stop
    204         Q
     1ORQ11 ;slc/dcm-Get patient orders in context ;3/31/04  09:57
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,78,99,94,148,141,177,186,190,195,215**;Dec 17, 1997
     3LOOP ; -- main loop through "ACT" x-ref
     4 I $G(XREF)="AW" D AW Q
     5 I $G(FLG)=27 D EXPD^ORQ12 Q
     6 K ^TMP("ORGOTIT",$J)
     7AWIN ;Jump in here to add active orders to AW context
     8 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195
     9 S NOW=+$E($$NOW^XLFDT,1,12),TM=SDATE
     10 F  S TM=$O(^OR(100,"ACT",PAT,TM)) Q:'TM!(TM>EDATE)  S TO=0 F  S TO=$O(^OR(100,"ACT",PAT,TM,TO)) Q:'TO  I $D(ORGRP(TO)) D
     11 . S IFN=0 F  S IFN=$O(^OR(100,"ACT",PAT,TM,TO,IFN)) Q:'IFN  I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT),$D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
     12 .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"ACT",PAT,TM,TO,IFN,ACTOR)) Q:ACTOR<1  I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13!(FLG=1) S X8=^(0),X7=$G(^(7)) D LP1
     13 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     14 Q
     15AW ; -- loop through "AW" x-ref
     16 K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J)
     17 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195
     18 S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE
     19 F  S TO=$O(^OR(100,"AW",PAT,TO)) Q:'TO  I $D(ORGRP(TO)) S TM=EDATE F  S TM=$O(^OR(100,"AW",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE)  D
     20 . S IFN=0 F  S IFN=$O(^OR(100,"AW",PAT,TO,TM,IFN)) Q:'IFN  I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D
     21 .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)=""
     22 S TM=0 F  S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM  S TO=0 F  S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO  D
     23 . S IFN=0 F  S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN  I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
     24 .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1  I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1
     25 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     26 I +$$GET^XPAR("SYS","OR ORDER SUMMARY CONTEXT",1,"I")=2 S SDATE=9999999-SDATE,EDATE=9999999-EDATE D AWIN
     27 K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J)
     28 Q
     29LP1 ; -- main secondary loop
     30 N STS ;195
     31 N TAG
     32 Q:$P(X3,U,8)  Q:$P(X3,U,3)=99  S STS=$P(X3,U,3)
     33 I '$G(GETKID),$P(X3,U,9),'$P($G(^OR(100,$P(X3,U,9),3)),U,8),FLG'=11 Q
     34 I $L($P(X0,U,17)),"^10^11^"[(U_STS_U) S X=$$LAPSED^OREVNTX($P(X0,U,17))
     35 S TAG=$S(FLG=2:"CUR1",FLG=4:"COM1",FLG=5:"EXG1",FLG=7:"PEN1",FLG=8:"UVR1",FLG=9:"UVN1",FLG=10:"UVC1",FLG=12:"FLG1",FLG=13:"VP1",FLG=14:"VPU1",FLG=18:"HLD1",FLG=20:"CHT1",FLG=21:"CHTSUM",FLG=22:"LPS1",FLG=23:"AVT1",1:"ALL1")
     36 I TAG="ALL1" S TAG=$S(FLG=3:"DC1",FLG=28:"DC1",1:"ALL1")
     37 D @TAG
     38 Q
     39 ; ** FLG context specific loops:
     40 ;
     41ALL1 ; 1 -- secondary pass for All, Recent Orders, Unsigned
     42 D GET^ORQ12(IFN,ORLIST,DETAIL,$G(ACTOR))
     43 Q
     44 ;
     45CUR ; 2 -- Active/Current
     46 N X,X0,X1,X2,X3,%H,YD,%,TM,IFN,ACTOR,OIEN,OACT
     47 I $G(GROUP)=$O(^ORD(100.98,"B","ALL SERVICES",0)),$G(ORWARD),$G(DGPMT)'=1 S X=$O(^ORD(100.98,"B","O RX",0)) K:X ORGRP(X) ; 177 screen out Outpt Meds if inpt
     48 S X2=+$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"I"),X=$H,X=+X*24+($P(X,",",2)/3600),X1=X-X2,X3=X1#24,X1=X1\24,X2=$J(X3*3600,0,0),%H=X1_","_X2 D YMD^%DTC S YD=+(X_%)
     49 S TM=SDATE F  S TM=$O(^OR(100,"AC",PAT,TM)) Q:TM<1!(TM>EDATE)  S IFN=0 F  S IFN=$O(^OR(100,"AC",PAT,TM,IFN)) Q:IFN<1  I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
     50 . Q:'$D(ORGRP($P(X0,U,11)))  S ACTOR=0
     51 . F  S ACTOR=$O(^OR(100,"AC",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  I $D(^OR(100,IFN,8,ACTOR,0)) S X=^(0) D
     52 .. I "^10^12^"[(U_$P(X,U,15)_U) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
     53 .. I $P(X,U,15)=13,$P(X,U)<YD K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
     54 .. I $P(X,U,15)="",ACTOR'=$P(X3,U,7) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
     55 .. ;AGP waiting for approval change to remove duplicate orders for DC reason
     56 .. ;I ACTOR>0,$P($G(^OR(100,IFN,8,ACTOR,0)),U,2)="DC" S OIEN=IFN,OACT=ACTOR
     57 .. ;I OIEN=IFN,OACT>ACTOR K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q
     58 .. D LP1
     59 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     60 Q
     61CUR1 ; 2 -- secondary pass for Active/Current
     62 N STOP S STOP=$P(X0,U,9)
     63 I STS=10 K ^OR(100,"AC",PAT,TM,IFN) Q  ;no delayed orders
     64 I '$D(YD),"^1^2^7^12^13^14^"[(U_STS_U) K ^OR(100,"AC",PAT,TM,IFN) Q
     65 I $D(YD),"^1^2^7^12^13^14^"[(U_STS_U),STOP<YD K ^OR(100,"AC",PAT,TM,IFN) Q
     66 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     67 Q
     68 ;
     69DC1 ; 3 -- secondary pass for DC
     70 I FLG=28 D GETEIE^ORQ12(IFN,ORLIST,DETAIL,ACTOR) Q
     71 I STS=1!(STS=13)!(STS=12) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     72 Q
     73 ;
     74COM1 ; 4 -- secondary pass for Completed/Expired
     75 N STOP S STOP=$P(X0,U,9)
     76 I STS=2!(STS=7)!($L(STOP)&(STOP<NOW)&(STS'=1)&(STS'=13)&(STS'=12)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     77 Q
     78 ;
     79EXG ; 5 -- Expiring
     80 N ORNG,ORDT,ORDW,ORHOL,X,Y,%DT,DIC,TMW,NOW ;195
     81 F ORNG=1:1 D  I ORHOL=0,ORDW=0 Q
     82 . S ORDT=$$FMADD^XLFDT(DT,ORNG),ORDW=$S($H-4+ORNG#7>4:1,1:0)
     83 . S DIC="^HOLIDAY(",X=$P(ORDT,".")
     84 . D ^DIC S ORHOL=$S(+$G(Y)>0:1,1:0)
     85 S %DT="",X="T+"_ORNG D ^%DT
     86 S TMW=Y_".9999",NOW=+$E($$NOW^XLFDT,1,12)
     87 D CUR ;D LOOP
     88 Q
     89EXG1 ; 5 -- secondary pass for Expiring
     90 N STOP S STOP=$P(X0,U,9)
     91 I STS'=1,STS'=2,STS'=7,STS'>9,STOP>NOW,STOP'>TMW D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     92 Q
     93 ;
     94ACT ; 6 -- Recent Activity (Order Summary)
     95 ;N ORLSIGN S ORLSIGN=$$GET^XPAR("ALL","OR ORDER REVIEW DT","`"_+PAT,"Q")
     96 N TM,IFN,X0,X3,ACTOR,X8
     97 S TM=SDATE F  S TM=$O(^OR(100,"AR",PAT,TM)) Q:TM<1!(TM>EDATE)  D
     98 . S IFN=0 F  S IFN=$O(^OR(100,"AR",PAT,TM,IFN)) Q:IFN<1  S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) I $D(ORGRP(+$P(X0,U,11))) D
     99 .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"AR",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  I $D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0) D LP1
     100 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     101 Q
     102 ;
     103PEN1 ; 7 -- secondary pass for Pending
     104 I STS=5 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     105 Q
     106 ;
     107UVR1 ; 8 -- secondary pass for Unverified
     108 ;      Include if: unverified, released, inpt, not repl/canc/lapsed
     109 I '$P(X8,U,9),'$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     110 Q
     111 ;
     112UVN1 ; 9 -- secondary pass for Unverified/Nurse
     113 ;      Include if: unverified, released, inpt, not repl/canc/lapsed
     114 I '$P(X8,U,9),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     115 Q
     116 ;
     117UVC1 ; 10 -- secondary pass for Unverified/Clerk
     118 ;       Include if: unverified, released, inpt, not repl/canc/lapsed
     119 I '$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     120 Q
     121 ;
     122INPT() ; -- Returns 1 or 0, if inpt order using X0=^OR(100,IFN,0)
     123 I ($P(X0,U,12)="I")!($P(X0,U,17)="D") Q 1
     124 I $P($G(^SC(+$P(X0,U,10),0)),U,3)="W" Q 1
     125 Q 0
     126 ;
     127SIG ; 11 -- Unsigned
     128 N TM,IFN,X0,X3,ACTOR S TM=SDATE
     129 F  S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE)  S IFN=0 F  S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1  D
     130 . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3))
     131 . I X0="" K ^OR(100,"AS",PAT,TM,IFN) Q  ;deleted
     132 . Q:'$D(ORGRP(+$P(X0,U,11)))  ;not a selected DispGrp
     133 . S ACTOR=0 F  S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  D
     134 .. I $P($G(^OR(100,IFN,8,ACTOR,0)),U,4)'=2 K ^OR(100,"AS",PAT,TM,IFN,ACTOR) Q  ;signed or deleted
     135 .. D LP1
     136 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     137 Q
     138 ;
     139FLG1 ; 12 -- secondary pass for Flagged
     140 I +$G(^OR(100,IFN,8,ACTOR,3)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     141 Q
     142 ;
     143VP1 ; 13 -- secondary pass for Verbal/Phone
     144 N ORNATR S ORNATR=$P(X8,U,12)
     145 I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12
     146 Q
     147 ;
     148VPU1 ; 14 -- secondary pass for Verbal/Phone Unsigned
     149 N ORNATR S ORNATR=$P(X8,U,12)
     150 I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2),'$P(X8,U,5),$P(X8,U,4)=2 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12
     151 Q
     152 ;
     153HLD1 ; 18 -- secondary pass for On Hold
     154 I STS=3 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     155 Q
     156 ;
     157NEW ; 19 -- New Orders, plus other unsigned orders by current provider
     158 N IFN,ACTOR,TM,X0,X3,X8,ORENT,ORPAR
     159 S IFN=0 F  S IFN=$O(^TMP("ORNEW",$J,IFN)) Q:IFN'>0  D  ;New orders
     160 . S ACTOR=0 F  S ACTOR=$O(^TMP("ORNEW",$J,IFN,ACTOR)) Q:ACTOR'>0  D
     161 .. Q:'$D(^OR(100,IFN,0))  Q:'$D(^(8,ACTOR,0))  ;deleted
     162 .. D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     163 G:'$D(^XUSEC("ORES",DUZ)) NW1 ;ck parameter for add'l orders
     164 S ORENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"")
     165 S ORPAR=$$GET^XPAR(ORENT,"OR UNSIGNED ORDERS ON EXIT")
     166 I ORPAR S TM=SDATE F  S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE)  D
     167 . S IFN=0 F  S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1  D
     168 .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1  D
     169 ... Q:$D(^TMP("ORNEW",$J,IFN,ACTOR))  ;already included
     170 ... S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACTOR,0))
     171 ... I $S(ORPAR=1&($P(X8,U,3)=DUZ):1,ORPAR=2:1,1:0) D LP1
     172NW1 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     173 Q
     174 ;
     175CHT1 ; 20 -- secondary pass for Chart Review
     176 ;       Include if: unverified, released, inpt, not repl/canc/lapsed
     177 I '$P(X8,U,19),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     178 Q
     179 ;
     180CHTSUM ; 21 -- secondary pass for Chart copy summary
     181 ;       Included based on Nature of Order
     182 N XP,NAT
     183 S XP=+$$GET^XPAR("SYS","OR PRINT ALL ORDERS CHART SUM",1,"I")
     184 I XP=2 D  Q  ;depends on Nature of Order
     185 . S NAT=$P($G(^OR(100,IFN,6)),U)
     186 . I 'NAT S NAT=$P(X8,U,12)
     187 . I NAT,$$CHART^ORX1(NAT) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     188 I XP=0 D  Q  ;If original printed, print on sum
     189 . I X7 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     190 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;XP=1 gets All orders
     191 Q
     192 ;
     193LPS1 ; 22 -- secondary pass for Lapsed
     194 I STS=14 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     195 Q
     196 ;
     197AVT1 ; 23 -- secondary pass for Active/Pending sts only
     198 I (STS=6)!(STS=5) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR)
     199 Q
     200 ;
     201QUIT ; -- stop
     202 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ12.m

    r613 r623  
    1 ORQ12   ; slc/dcm - Get patient orders in context ;06/29/06
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215,243**;Dec 17, 1997;Build 242
    3 GET(IFN,NEWD,DETAIL,ACTOR)      ; -- Setup TMP array
    4         ; IFN=ifn of order
    5         ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
    6         ; DETAIL=see description in ^ORQ1
    7         ;
    8         N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD
    9         S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))=""
    10         I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q
    11         S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6))
    12         S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3)
    13         S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr
    14         S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9)
    15         ; S FLAGREA=$P(X6,U,7)
    16         S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
    17         D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT
    18         Q
    19         ;
    20 TEXT(ORTX,ORIFN,WIDTH)  ; -- Returns text of order ORIFN in ORTX(#)
    21         N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA
    22         K ORTX S:'$G(WIDTH) WIDTH=244
    23         S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN
    24         I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1
    25         ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf
    26         S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0))
    27         S ORTX=1,ORTX(1)=""
    28         I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD
    29         G:$G(ORIGVIEW)>1 T1
    30         S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic
    31         S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD
    32         I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D  ; Changed or Renewed
    33         . I $P(OR3,U,11)=2 S X="Renew" D ADD Q
    34         . N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG  Q:$P(OR3,U,11)'=1
    35         . S X="Change" D ADD S ORI=0
    36         . I $G(IOST)'="P-OTHER" D
    37         . .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG)
    38         . .F  S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0  S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD
    39         . .S X=" to" D ADD
    40 T1      S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0))
    41         S ORI=0 F  S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0  S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD
    42         Q:$G(ORIGVIEW)>1  ;contents of global only
    43         S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text
    44         ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD
    45         I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD
    46         I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason
    47         I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP
    48         Q
    49         ;
    50 LASTXT(IFN)         ; -- Returns action with latest text for order IFN
    51         N I,Y S Y=1
    52         S I=0 F  S I=$O(^OR(100,IFN,8,I)) Q:I'>0  S:$O(^(I,.1,0)) Y=I
    53         Q Y
    54         ;
    55 LAST(CODE)      ; -- Return DA of last occurence of CODE action
    56         N DA
    57         I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry
    58         E  S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry
    59         Q DA
    60         ;
    61 ACTION(X)       ; -- Returns text of action X
    62         N Y
    63         S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"")
    64         Q Y
    65         ;
    66 DATETIME(X)     ; -- Returns date/time in format 00/00/00@00:00am
    67         N Y,D,T,T1,Z
    68         S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM"
    69         S:T1>12 T1=T1-12,Z="PM"
    70         S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z
    71         Q Y
    72         ;
    73 NAME(X) ; -- Returns name as Lname,F
    74         N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" ""
    75         S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q
    76         S Y=$$LOWER^VALM1(Y) ; mixed case
    77         Q Y
    78         ;
    79 ADD     ; -- Add text X to ORTX()
    80         N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space
    81         I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line
    82         I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q
    83         F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH  S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1
    84         . I $L(Z)>WIDTH F  S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH  S ORTX=ORTX+1,Y=0
    85         . S ORTX=ORTX+1,Y=0
    86         Q
    87         ;
    88 EXPD    ; -- loop through ^XTMP("ORAE" to get expired orders
    89         K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J)
    90         N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP
    91         S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE
    92         F  S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO  I $D(ORGRP(TO)) S TM=EDATE F  S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE)  D
    93         . S IFN=0 F  S IFN=$O(^XTMP("ORAE",PAT,TO,TM,IFN)) Q:'IFN  I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D
    94         .. S USTS=$P(^OR(100,IFN,3),U,3)
    95         .. Q:+$G(USTS)'=7  ;quit if order no longer expired
    96         .. S ORREP=$P(^OR(100,IFN,3),U,6)
    97         .. Q:+$G(ORREP)>0  ;quit if order has been replaced
    98         .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)=""
    99         S TM=0 F  S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM  S TO=0 F  S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO  D
    100         .S IFN=0 F  S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN  I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
    101         ..S ACTOR=+$P(X3,U,7) D LP1^ORQ11
    102         ..;S ACTOR=0 F  S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1  I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11
    103         S ^TMP("ORR",$J,ORLIST,"TOT")=$G(ORLST)
    104         K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J)
    105         Q
    106 GETEIE(IFN,NEWD,DETAIL,ACTOR)   ; -- Setup TMP array
    107         ; IFN=ifn of order
    108         ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
    109         ; DETAIL=see description in ^ORQ1
    110         ;
    111         N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS
    112         S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6))
    113         S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3)
    114         S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"")
    115         S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9)
    116         S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0
    117         I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q
    118         S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))=""
    119         I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q
    120         S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
    121         D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT
    122         Q
     1ORQ12 ; slc/dcm - Get patient orders in context ;12/19/05
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215**;Dec 17, 1997
     3GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array
     4 ; IFN=ifn of order
     5 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
     6 ; DETAIL=see description in ^ORQ1
     7 ;
     8 N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD
     9 S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))=""
     10 I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q
     11 S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6))
     12 S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3)
     13 S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr
     14 S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9)
     15 ; S FLAGREA=$P(X6,U,7)
     16 S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
     17 D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT
     18 Q
     19 ;
     20TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#)
     21 N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA
     22 K ORTX S:'$G(WIDTH) WIDTH=244
     23 S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN
     24 I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1
     25 ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf
     26 S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0))
     27 S ORTX=1,ORTX(1)=""
     28 I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD
     29 G:$G(ORIGVIEW)>1 T1
     30 S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic
     31 S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD
     32 I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D  ; Changed or Renewed
     33 . I $P(OR3,U,11)=2 S X="Renew" D ADD Q
     34 . N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG  Q:$P(OR3,U,11)'=1
     35 . S X="Change" D ADD S ORI=0
     36 . I $G(IOST)'="P-OTHER" D
     37 . .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG)
     38 . .F  S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0  S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD
     39 . .S X=" to" D ADD
     40T1 S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0))
     41 S ORI=0 F  S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0  S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD
     42 Q:$G(ORIGVIEW)>1  ;contents of global only
     43 S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text
     44 ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD
     45 I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD
     46 I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason
     47 I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP
     48 Q
     49 ;
     50LASTXT(IFN)     ; -- Returns action with latest text for order IFN
     51 N I,Y S Y=1
     52 S I=0 F  S I=$O(^OR(100,IFN,8,I)) Q:I'>0  S:$O(^(I,.1,0)) Y=I
     53 Q Y
     54 ;
     55LAST(CODE) ; -- Return DA of last occurence of CODE action
     56 N DA
     57 I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry
     58 E  S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry
     59 Q DA
     60 ;
     61ACTION(X) ; -- Returns text of action X
     62 N Y
     63 S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"")
     64 Q Y
     65 ;
     66DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am
     67 N Y,D,T,T1,Z
     68 S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM"
     69 S:T1>12 T1=T1-12,Z="PM"
     70 S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z
     71 Q Y
     72 ;
     73NAME(X) ; -- Returns name as Lname,F
     74 N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" ""
     75 S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q
     76 S Y=$$LOWER^VALM1(Y) ; mixed case
     77 Q Y
     78 ;
     79ADD ; -- Add text X to ORTX()
     80 N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space
     81 I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line
     82 I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q
     83 F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH  S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1
     84 . I $L(Z)>WIDTH F  S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH  S ORTX=ORTX+1,Y=0
     85 . S ORTX=ORTX+1,Y=0
     86 Q
     87 ;
     88EXPD ; -- loop through ^XTMP("ORAE" to get expired orders
     89 K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J)
     90 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP
     91 S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE
     92 F  S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO  I $D(ORGRP(TO)) S TM=EDATE F  S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE)  D
     93 . S IFN=0 F  S IFN=$O(^XTMP("ORAE",PAT,TO,TM,IFN)) Q:'IFN  I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D
     94 .. S USTS=$P(^OR(100,IFN,3),U,3)
     95 .. Q:+$G(USTS)'=7  ;quit if order no longer expired
     96 .. S ORREP=$P(^OR(100,IFN,3),U,6)
     97 .. Q:+$G(ORREP)>0  ;quit if order has been replaced
     98 .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)=""
     99 S TM=0 F  S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM  S TO=0 F  S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO  D
     100 . S IFN=0 F  S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN  I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
     101 .. S ACTOR=0 F  S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1  I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11
     102 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST
     103 K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J)
     104 Q
     105GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array
     106 ; IFN=ifn of order
     107 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
     108 ; DETAIL=see description in ^ORQ1
     109 ;
     110 N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS
     111 S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6))
     112 S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3)
     113 S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"")
     114 S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9)
     115 S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0
     116 I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q
     117 S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))=""
     118 I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q
     119 S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
     120 D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT
     121 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ2.m

    r613 r623  
    1 ORQ2    ; SLC/MKB/GSS - Detailed Order Report ;10/10/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195,243**;Dec 17, 1997;Build 242
    3 DETAIL(ORY,ORIFN)       ; -- Returns details of order ORIFN in ORY(#)
    4         N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT
    5         S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6))
    6         K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx
    7         M @ORY=ORYT ;Move text to global
    8         S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0  D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF)
    9         S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    10 D1      I $O(^OR(100,+ORIFN,2,0)) D
    11         . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:"
    12         . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF)
    13         . N IFN S IFN=0
    14         . F  S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1  I $D(^OR(100,IFN,0)) D SUB(IFN)
    15         . S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    16         I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D
    17         . S CNT=CNT+1,@ORY@(CNT)="Parent Order:"
    18         . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF)
    19         . D SUB(+$P(OR3,U,9))
    20         . S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    21         I $P(OR3,U,11)=1,$P(OR3,U,5) D  ;Changed - show previous order
    22         . S CNT=CNT+1,@ORY@(CNT)="Previous Order:"
    23         . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text
    24         . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55)
    25         . S CNT=CNT+1,@ORY@(CNT)="     Order Text:        "_$G(ORZ(1))
    26         . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
    27 D2      S CNT=CNT+1,@ORY@(CNT)="Activity:"
    28         D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF)
    29         S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W")
    30         F  S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0  S ACTION=$G(^(ORI,0)) D ACT^ORQ20
    31         I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20
    32         I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_"  Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"")
    33         S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    34 D3      S CNT=CNT+1,@ORY@(CNT)="Current Data:"
    35         D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)
    36         D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider:     "_$P(VAIN(2),"^",2)
    37         I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician:  "_$P(VAIN(11),"^",2)
    38         S CNT=CNT+1,@ORY@(CNT)="Treating Specialty:           "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U)
    39         S CNT=CNT+1,@ORY@(CNT)="Ordering Location:            "_$P($G(^SC(+$P(OR0,U,10),0)),U)
    40         S CNT=CNT+1,@ORY@(CNT)="Start Date/Time:              "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"")
    41         I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")"
    42         S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time:               "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"")
    43         I $P(OR3,U,3)=1,$P(OR6,U,6) S @ORY@(CNT)=@ORY@(CNT)_"  (expired "_$$DATE^ORQ20($P(OR6,U,6))_")"
    44         S CNT=CNT+1,@ORY@(CNT)="Current Status:               "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-")
    45         I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F  S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1  S CNT=CNT+1,@ORY@(CNT)="  "_^(J,0)
    46         S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN
    47         S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    48 D4      S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF)
    49         S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
    50         I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q
    51         S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101,"  ; 2.5 order
    52         D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN)
    53         S DIWL=1,DIWR=50,DIWF="C50"
    54         S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
    55         . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11)  ; child
    56         . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*"  ;hide
    57         . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST  ; no values
    58         . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A"))
    59         . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))
    60         . S INST=0 F  S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0  D
    61         . . I $E(ORDIALOG(PRMT,0))="W" D WP Q
    62         . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) I TITLE["Infusion Rate"&(X'="")&(X'["ml/hr") S TITLE="Infuse Over Time:",TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))
    63         . . D ^DIWP
    64         . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT)
    65         . . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0)
    66         I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.:                  "_+^(4)
    67         S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    68         D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data
    69         D BA^ORQ21 ;call for CIDC data
    70 D5      I $O(^OR(100,+ORIFN,9,0)) D
    71         . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:"
    72         . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)
    73         . S CK=0 F  S CK=$O(^OR(100,+ORIFN,9,CK)) Q:CK'>0  S X0=$G(^(CK,0)),X=$G(^(1)) D
    74         .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)
    75         .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q
    76         .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP
    77         .. S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL="            "
    78         . Q:'$L($G(OK))  S CNT=CNT+1,@ORY@(CNT)="Override:   "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3))
    79         . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)="            "_$P(OK,U) Q
    80         . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP
    81         . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="            "_^(I,0)
    82         K ^TMP("ORWORD",$J),^UTILITY($J,"W")
    83         Q
    84         ;
    85 SUB(IFN)        ; -- add suborder or parent
    86         N ORCY,STS,STRT,IG D TEXT^ORQ12(.ORCY,IFN,58)
    87         S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1))
    88         S STRT=$P(^OR(100,IFN,0),U,8) S:STRT'="" STRT=$$DATE^ORQ20(STRT)
    89         S IG=0 F  S IG=$O(ORCY(IG)) Q:IG<1  S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" "
    90         Q
    91         ;
    92 WP      ; -- add word-processing
    93         N WP,ORI,X M WP=@ORDIALOG(PRMT,INST)
    94         S CNT=CNT+1,@ORY@(CNT)=TITLE
    95         S ORI=0 F  S ORI=$O(WP(ORI)) Q:ORI'>0  S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)="  "_X
    96         Q
    97         ;
    98 CHILDREN(PARENT)        ; -- add children
    99         N SEQ,DA,ITM,PRMT,TYPE,X
    100         S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D
    101         . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2)
    102         . Q:$G(ORDIALOG(PRMT,INST))=""  Q:$P(ITM,U,9)["*"  ;no value or hide
    103         . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP
    104         . I TYPE'="W" D
    105         . . S X=$$EXT^ORCD(PRMT,INST)
    106         . . I $L(X,"|")=2 S X=$$REPLACE^ORHLESC(X,"|","||")
    107         . . D ^DIWP
    108         Q
    109         ;
    110 SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes
    111         S ORY("VIDEO",LINE,COL,WIDTH)=ON
    112         S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF
    113         Q
    114         ;
    115 VA      ; -- Call VADPT
    116         N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT
    117         Q
    118         ;
    119 CDL(X)  ; -- Returns Clinical Danger Level X
    120         N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:")
    121         S Y=$E(Y_"        ",1,12)
    122         Q Y
    123         ;
    124 ORIG(IFN)       ; -- Return original start date of [renewal] order
    125         N I,Y,X3,DONE
    126         S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0
    127         F  S X3=$G(^OR(100,I,3)) D  Q:DONE
    128         . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q  ;loop
    129         . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1
    130         Q Y
     1ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;7/1/04  10:58
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195**;Dec 17, 1997
     3DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#)
     4 N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT
     5 S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6))
     6 K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx
     7 M @ORY=ORYT ;Move text to global
     8 S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0  D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF)
     9 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     10D1 I $O(^OR(100,+ORIFN,2,0)) D
     11 . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:"
     12 . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF)
     13 . N IFN S IFN=0
     14 . F  S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1  I $D(^OR(100,IFN,0)) D SUB(IFN)
     15 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     16 I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D
     17 . S CNT=CNT+1,@ORY@(CNT)="Parent Order:"
     18 . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF)
     19 . D SUB(+$P(OR3,U,9))
     20 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     21 I $P(OR3,U,11)=1,$P(OR3,U,5) D  ;Changed - show previous order
     22 . S CNT=CNT+1,@ORY@(CNT)="Previous Order:"
     23 . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text
     24 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55)
     25 . S CNT=CNT+1,@ORY@(CNT)="     Order Text:        "_$G(ORZ(1))
     26 . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
     27D2 S CNT=CNT+1,@ORY@(CNT)="Activity:"
     28 D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF)
     29 S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W")
     30 F  S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0  S ACTION=$G(^(ORI,0)) D ACT^ORQ20
     31 I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20
     32 I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_"  Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"")
     33 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     34D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:"
     35 D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)
     36 D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider:     "_$P(VAIN(2),"^",2)
     37 I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician:  "_$P(VAIN(11),"^",2)
     38 S CNT=CNT+1,@ORY@(CNT)="Treating Specialty:           "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U)
     39 S CNT=CNT+1,@ORY@(CNT)="Ordering Location:            "_$P($G(^SC(+$P(OR0,U,10),0)),U)
     40 S CNT=CNT+1,@ORY@(CNT)="Start Date/Time:              "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"")
     41 I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")"
     42 S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time:               "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"")
     43 S CNT=CNT+1,@ORY@(CNT)="Current Status:               "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-")
     44 I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F  S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1  S CNT=CNT+1,@ORY@(CNT)="  "_^(J,0)
     45 S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN
     46 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     47D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF)
     48 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
     49 I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q
     50 S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101,"  ; 2.5 order
     51 D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN)
     52 S DIWL=1,DIWR=50,DIWF="C50"
     53 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
     54 . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11)  ; child
     55 . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*"  ;hide
     56 . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST  ; no values
     57 . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A"))
     58 . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))
     59 . S INST=0 F  S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0  D
     60 . . I $E(ORDIALOG(PRMT,0))="W" D WP Q
     61 . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) D ^DIWP
     62 . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT)
     63 . . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0)
     64 I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.:                  "_+^(4)
     65 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     66 D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data
     67 D BA^ORQ21 ;call for CIDC data
     68D5 I $O(^OR(100,+ORIFN,9,0)) D
     69 . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:"
     70 . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)
     71 . S CK=0 F  S CK=$O(^OR(100,+ORIFN,9,CK)) Q:CK'>0  S X0=$G(^(CK,0)),X=$G(^(1)) D
     72 .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)
     73 .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q
     74 .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP
     75 .. S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL="            "
     76 . Q:'$L($G(OK))  S CNT=CNT+1,@ORY@(CNT)="Override:   "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3))
     77 . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)="            "_$P(OK,U) Q
     78 . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP
     79 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="            "_^(I,0)
     80 K ^TMP("ORWORD",$J),^UTILITY($J,"W")
     81 Q
     82 ;
     83SUB(IFN) ; -- add suborder or parent
     84 N ORCY,STS,STRT,IG D TEXT^ORQ12(.ORCY,IFN,58)
     85 S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1))
     86 S STRT=$P(^OR(100,IFN,0),U,8) S:STRT'="" STRT=$$DATE^ORQ20(STRT)
     87 S IG=0 F  S IG=$O(ORCY(IG)) Q:IG<1  S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" "
     88 Q
     89 ;
     90WP ; -- add word-processing
     91 N WP,ORI,X M WP=@ORDIALOG(PRMT,INST)
     92 S CNT=CNT+1,@ORY@(CNT)=TITLE
     93 S ORI=0 F  S ORI=$O(WP(ORI)) Q:ORI'>0  S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)="  "_X
     94 Q
     95 ;
     96CHILDREN(PARENT) ; -- add children
     97 N SEQ,DA,ITM,PRMT,TYPE,X
     98 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D
     99 . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2)
     100 . Q:$G(ORDIALOG(PRMT,INST))=""  Q:$P(ITM,U,9)["*"  ;no value or hide
     101 . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP
     102 . I TYPE'="W" S X=$$EXT^ORCD(PRMT,INST) D ^DIWP
     103 Q
     104 ;
     105SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes
     106 S ORY("VIDEO",LINE,COL,WIDTH)=ON
     107 S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF
     108 Q
     109 ;
     110VA ; -- Call VADPT
     111 N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT
     112 Q
     113 ;
     114CDL(X) ; -- Returns Clinical Danger Level X
     115 N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:")
     116 S Y=$E(Y_"        ",1,12)
     117 Q Y
     118 ;
     119ORIG(IFN) ; -- Return original start date of [renewal] order
     120 N I,Y,X3,DONE
     121 S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0
     122 F  S X3=$G(^OR(100,I,3)) D  Q:DONE
     123 . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q  ;loop
     124 . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1
     125 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ20.m

    r613 r623  
    1 ORQ20   ; SLC/MKB - Detailed Order Report cont ;3/6/08  10:25
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,92,94,116,141,177,186,190,215,243**;Dec 17, 1997;Build 242
    3 ACT     ; -- add Activity [from ^ORQ2]
    4         N ORACT S ORACT=$P(ACTION,U,2)
    5         I ORACT'="NW",$P(ACTION,U,4)=5,$P(ACTION,U,15)=13 Q  ;skip canc actions
    6         N NVA,USER S:$P(^ORD(100.98,$P(^OR(100,+ORIFN,0),U,11),0),U)="NON-VA MEDICATIONS" NVA=1
    7         S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(ACTION,U))_"  "_$$ACTION(ORACT)
    8         I $P(ACTION,U,13) S @ORY@(CNT)=@ORY@(CNT)_" entered by "_$$USER(+$P(ACTION,U,13))
    9         I ORACT="NW" D  ;Show original order text
    10         . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";1",80)
    11         . S CNT=CNT+1,@ORY@(CNT)="     Order Text:        "_$G(ORZ(1))
    12         . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
    13         I ORACT="XX" D  ;Changed - show new text
    14         . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";"_ORI,80)
    15         . S CNT=CNT+1,@ORY@(CNT)="     Changed to:        "_$G(ORZ(1))
    16         . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
    17 A1      I $P(ACTION,U,12) D  ;Nature of Order/Release
    18         . N ORZ S ORZ=$G(^ORD(100.02,+$P(ACTION,U,12),0))
    19         . S CNT=CNT+1,@ORY@(CNT)="     Nature of Order:   "_$P(ORZ,U)
    20         . I $P(OR0,U,17),(ORACT="NW") Q  ;see event
    21         . I "^V^P^"[(U_$P(ORZ,U,2)_U),$P(ACTION,U,16) S CNT=CNT+1,@ORY@(CNT)="     Released by:       "_$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16))
    22         I $P(OR0,U,17)&(ORACT="NW") D  ;Delayed Release Event
    23         . N EVT,X,ORV,I S EVT=+$P(OR0,U,17),X=$$NAME^OREVNTX(EVT)
    24         . S:$E(X,1,8)="Delayed " X=$E(X,9,99)
    25         . I $G(^ORE(100.2,EVT,1)),'$P(ACTION,U,16) S X=X_" on "_$$DATE(+^(1))
    26         . S CNT=CNT+1,@ORY@(CNT)="     Delayed Until:     "_X Q:'$P(ACTION,U,16)
    27         . D EVENT(.ORV) S CNT=CNT+1,@ORY@(CNT)="     Released by:       "_ORV(1)
    28         . S I=1 F  S I=$O(ORV(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I))
    29 A2      I $P(ACTION,U,5) S CNT=CNT+1,@ORY@(CNT)=$S($P(ACTION,U,4)=7:"      Dig",1:"     Elec")_" Signature:    "_$$USER(+$P(ACTION,U,5))_" on "_$$DATE($P(ACTION,U,6))
    30         I '$P(ACTION,U,5)!($P(ACTION,U,3)'=$P(ACTION,U,5)),'$$SERVCORR S CNT=CNT+1,@ORY@(CNT)="     "_$S($D(NVA):"Documented by:",1:"Ordered by:   ")_"     "_$$USER(+$P(ACTION,U,3))
    31         I '$P(ACTION,U,5),$L($P(ACTION,U,4)) D
    32         .I $P(ACTION,U,4)=0 D
    33         ..S USER=$$USER(+$P(ACTION,U,7))
    34         ..S CNT=CNT+1
    35         ..I USER'="" S @ORY@(CNT)="     Released by:       "_USER_" on "_$$DATE($P(ACTION,U,16))
    36         ..I USER="" S @ORY@(CNT)="        Released:       "_$$DATE($P(ACTION,U,16))
    37         .S CNT=CNT+1,@ORY@(CNT)="     Signature:         "_$$SIG($P(ACTION,U,4)) ;186
    38         ;I '$P(ACTION,U,5),$L($P(ACTION,U,4)) S:$P(ACTION,U,4)=0 CNT=CNT+1,@ORY@(CNT)="     Released by:       "_$$USER(+$P(ACTION,U,7))_" on "_$$DATE($P(ACTION,U,16)) S CNT=CNT+1,@ORY@(CNT)="     Signature:         "_$$SIG($P(ACTION,U,4)) ;186
    39         I $P(ACTION,U,9) S CNT=CNT+1,@ORY@(CNT)="     Nurse Verified:    "_$S($P(ACTION,U,8):$$USER(+$P(ACTION,U,8))_" on ",1:"")_$$DATE($P(ACTION,U,9))
    40         I $P(ACTION,U,11) S CNT=CNT+1,@ORY@(CNT)="     Clerk Verified:    "_$S($P(ACTION,U,10):$$USER(+$P(ACTION,U,10))_" on ",1:"")_$$DATE($P(ACTION,U,11))
    41         I $P(ACTION,U,19) S CNT=CNT+1,@ORY@(CNT)="     Chart Reviewed:    "_$S($P(ACTION,U,18):$$USER(+$P(ACTION,U,18))_" on ",1:"")_$$DATE($P(ACTION,U,19))
    42 A3      I $P(ACTION,U,2)="DC",$L(OR6) S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)="     Reason for DC:     "_X
    43         I $L($G(^OR(100,ORIFN,8,ORI,1))) S X=^(1) D  ;add backdoor comments
    44         . N LBL,I S LBL=""
    45         . I $P(ACTION,U,15)="",$P(ACTION,U,2)'="DC" S LBL="     Comments:          " ;DC shown above
    46         . I $P(ACTION,U,15)=13,$P(ACTION,U,2)'="NW" S LBL="     Cancelled:         " ;NW shown in ORQ2
    47         . Q:'$L(LBL)  I $L(X)'>56 S CNT=CNT+1,@ORY@(CNT)=LBL_X Q
    48         . S DIWL=1,DIWR=56,DIWF="C56" K ^UTILITY($J,"W") D ^DIWP
    49         . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=LBL_^(I,0),LBL="                        "
    50         I $D(^OR(100,ORIFN,8,ORI,5)) D  ;Ward comments
    51         . N X,ORJ K ^UTILITY($J,"W")
    52         . S ORJ=0 F  S ORJ=$O(^OR(100,ORIFN,8,ORI,5,ORJ)) Q:ORJ'>0  S X=^(ORJ,0) D ^DIWP
    53         . S ORJ=0 F  S ORJ=$O(^UTILITY($J,"W",DIWL,ORJ)) Q:ORJ'>0  S CNT=CNT+1,@ORY@(CNT)=$S(ORJ=1:"     Ward/Clinic Cmmts: ",1:"                        ")_^(ORJ,0)
    54         . K ^UTILITY($J,"W")
    55 A4      I $P(ACTION,U,2)="HD",$G(^OR(100,ORIFN,8,ORI,2)) S X2=^(2),CNT=CNT+1,@ORY@(CNT)="     Hold Released:     "_$$FMTE^XLFDT($P(X2,U),"2P")_" by "_$$USER($P(X2,U,2))
    56         I $D(^OR(100,ORIFN,8,ORI,3)) D  ;Un-/Flagged
    57         . N X S X=$G(^OR(100,ORIFN,8,ORI,3))
    58         . S CNT=CNT+1,@ORY@(CNT)="     Flagged by:        "_$$USER(+$P(X,U,4))_" on "_$$DATE($P(X,U,3))
    59         . S CNT=CNT+1,@ORY@(CNT)="                        "_$P(X,U,5)
    60         . Q:X  S CNT=CNT+1,@ORY@(CNT)="     Unflagged by:      "_$$USER(+$P(X,U,7))_" on "_$$DATE($P(X,U,6))
    61         . S CNT=CNT+1,@ORY@(CNT)="                        "_$P(X,U,8)
    62         Q
    63         ;
    64 DC      ; -- Add Reason for DC
    65         S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(OR6,U,3))_$S($P(OR6,U,8):"  Auto-",1:"  ")_"Discontinued"
    66         I $P(OR6,U,8) D  Q
    67         . N EVT,PKG,ORV,I
    68         . S EVT=$P(OR6,U,8),PKG=$P($G(^ORE(100.2,+EVT,3,ORIFN,0)),U,2)
    69         . S @ORY@(CNT)=@ORY@(CNT)_" by "_$S(PKG="FH":"DIETETICS",PKG="LR":"LABORATORY",PKG="PS":"PHARMACY",1:"CPRS")
    70         . D EVENT(.ORV,1) S CNT=CNT+1,@ORY@(CNT)="     Patient Movement:  "_ORV(1)
    71         . S I=1 F  S I=$O(ORV(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I))
    72         I $P(OR6,U,2),$P($G(^ORD(100.02,+$P(OR6,U),0)),U,2)'="A" S @ORY@(CNT)=@ORY@(CNT)_" by "_$$USER($P(OR6,U,2)) ;don't show user name if auto-dc
    73         N X S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)="     Reason for DC:     "_X
    74         Q
    75         ;
    76 ACTION(CODE)    ; -- Return name of action CODE
    77         N NAME S NAME=$S(CODE="NW":"New Order",CODE="DC":"Discontinue",CODE="HD":"Hold",CODE="RL":"Release Hold",CODE="RN":"Renewal",CODE="XX":"Change",1:"")
    78         I CODE="NW",$P(OR3,U,11) S NAME=NAME_$S($P(OR3,U,11)=1:" (Change)",$P(OR3,U,11)=2:" (Renewal)",1:"")
    79         Q NAME
    80         ;
    81 XACT(X) ; -- Return name of transaction code X
    82         N Y S X=$G(X)
    83         S Y=$S(X="XX":"Edited",X="DC":"Discontinued",X="HD":"Held",X="RL":"Hold Released",X="FW":"Forwarded",X="CA":"Cancelled",1:"")
    84         Q Y
    85         ;
    86 DATE(X) ; -- Return date formatted as 00/00/0000 00:00
    87         N T,Y  S T=$P(X,".",2)_"0000"
    88         S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
    89         I T S Y=Y_" "_$E(T,1,2)_":"_$E(T,3,4)
    90         Q Y
    91         ;
    92 USER(X) ; -- Returns NAME (TITLE) of New Person X
    93         N X0,Y S X0=$G(^VA(200,+X,0)),Y=$P(X0,U)
    94         S:$P(X0,U,9) Y=Y_" ("_$E($P($G(^DIC(3.1,+$P(X0,U,9),0)),U),1,15)_")"
    95         Q Y
    96         ;
    97 SIG(X)  ; -- Returns text of signature status X
    98         N Y S Y=""
    99         I X=0 S Y="ON CHART WITH WRITTEN ORDERS"
    100         I X=1 S Y="ELECTRONICALLY SIGNED"
    101         I X=2 S Y="NOT SIGNED"
    102         I X=3 S Y="NOT REQUIRED"
    103         I X=4 S Y="ON CHART WITH PRINTED ORDERS"
    104         I X=5 S Y="NOT REQUIRED DUE TO SERVICE CANCEL/LAPSE"
    105         I X=6 S Y="SERVICE CORRECTION TO SIGNED ORDER"
    106         Q Y
    107         ;
    108 SERVCORR()      ; -- Returns 1 or 0, if current ACTION is a serv corr change
    109         N Y,NATURE,I,X S Y=0
    110         G:ORACT'="XX" SCQ
    111         S NATURE=+$P(ACTION,U,12),NATURE=$P($G(^ORD(100.02,NATURE,0)),U,2)
    112         I "^S^I^"'[(U_NATURE_U) G SCQ
    113         S I=$O(^OR(100,ORIFN,8,ORI),-1),X=$G(^(I,0))
    114         I $P(X,U,3)'=$P(ACTION,U,3),$P(X,U,5)'=$P(ACTION,U,3) G SCQ ;show prov
    115         S Y=1
    116 SCQ     Q Y
    117         ;
    118 EVENT(ORTX,DC)  ; -- Returns patient event info for EVT
    119         N EVT1,REL,X,Y,I,ORMAX
    120         S ORTX(1)="" ;177
    121         S EVT1=$G(^ORE(100.2,EVT,1)),REL=$G(^ORE(100.2,EVT,2,ORIFN,0))
    122         ; Return event data if AutoDC or auto-released by an event:
    123         I $G(DC)!(REL&'$L($P(REL,U,2))&($P(EVT1,U,2)!$P(EVT1,U,4))) D  Q
    124         . S Y=$S($P(EVT1,U,5):$P(EVT1,U,5),1:EVT) ;parent owns Activity
    125         . S Y=+$O(^ORE(100.2,+Y,10,0)),Y=$G(^(Y,0)),X=$P(Y,U,4) Q:'$L(X)
    126         . S X=$S(X="A":"ADMISSION",X="T":"TRANSFER",X="D":"DISCHARGE",X="S":"SPECIALTY CHANGE",1:$S($P(EVT1,U)>$$DPI^ORUTL1("SR*3.0*157"):"IN TO O.R.",1:"OUT OF O.R."))_" on "_$$DATE($P(EVT1,U)) ;243
    127         . S ORTX(1)=X,ORTX=1,ORMAX=56
    128         . I $P(Y,U,6) S X=$S($P(Y,U,4)="D":"from ",1:"to ")_$$GET1^DIQ(45.7,+$P(Y,U,6)_",",.01) D TXT^ORCHTAB
    129         . I $P(Y,U,7) S X="on "_$$GET1^DIQ(42,+$P(Y,U,7)_",",.01) D TXT^ORCHTAB
    130         S X=$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16))
    131         I ORIFN'=+$P($G(^ORE(100.2,EVT,0)),U,4),$P(REL,U,2)="MN" S X=X_" (manually released)"
    132         S ORTX(1)=X
    133         Q
     1ORQ20 ; SLC/MKB - Detailed Order Report cont ;7/23/03  12:29
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,92,94,116,141,177,186,190,215**;Dec 17, 1997
     3ACT ; -- add Activity [from ^ORQ2]
     4 N ORACT S ORACT=$P(ACTION,U,2)
     5 N NVA S:$P(^ORD(100.98,$P(^OR(100,+ORIFN,0),U,11),0),U)="NON-VA MEDICATIONS" NVA=1
     6 S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(ACTION,U))_"  "_$$ACTION(ORACT)
     7 I $P(ACTION,U,13) S @ORY@(CNT)=@ORY@(CNT)_" entered by "_$$USER(+$P(ACTION,U,13))
     8 I ORACT="NW" D  ;Show original order text
     9 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";1",80)
     10 . S CNT=CNT+1,@ORY@(CNT)="     Order Text:        "_$G(ORZ(1))
     11 . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
     12 I ORACT="XX" D  ;Changed - show new text
     13 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";"_ORI,80)
     14 . S CNT=CNT+1,@ORY@(CNT)="     Changed to:        "_$G(ORZ(1))
     15 . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
     16A1 I $P(ACTION,U,12) D  ;Nature of Order/Release
     17 . N ORZ S ORZ=$G(^ORD(100.02,+$P(ACTION,U,12),0))
     18 . S CNT=CNT+1,@ORY@(CNT)="     Nature of Order:   "_$P(ORZ,U)
     19 . I $P(OR0,U,17),(ORACT="NW") Q  ;see event
     20 . I "^V^P^"[(U_$P(ORZ,U,2)_U),$P(ACTION,U,16) S CNT=CNT+1,@ORY@(CNT)="     Released by:       "_$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16))
     21 I $P(OR0,U,17)&(ORACT="NW") D  ;Delayed Release Event
     22 . N EVT,X,ORV,I S EVT=+$P(OR0,U,17),X=$$NAME^OREVNTX(EVT)
     23 . S:$E(X,1,8)="Delayed " X=$E(X,9,99)
     24 . I $G(^ORE(100.2,EVT,1)),'$P(ACTION,U,16) S X=X_" on "_$$DATE(+^(1))
     25 . S CNT=CNT+1,@ORY@(CNT)="     Delayed Until:     "_X Q:'$P(ACTION,U,16)
     26 . D EVENT(.ORV) S CNT=CNT+1,@ORY@(CNT)="     Released by:       "_ORV(1)
     27 . S I=1 F  S I=$O(ORV(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I))
     28A2 I $P(ACTION,U,5) S CNT=CNT+1,@ORY@(CNT)=$S($P(ACTION,U,4)=7:"      Dig",1:"     Elec")_" Signature:    "_$$USER(+$P(ACTION,U,5))_" on "_$$DATE($P(ACTION,U,6))
     29 I '$P(ACTION,U,5)!($P(ACTION,U,3)'=$P(ACTION,U,5)),'$$SERVCORR S CNT=CNT+1,@ORY@(CNT)="     "_$S($D(NVA):"Documented by:",1:"Ordered by:   ")_"     "_$$USER(+$P(ACTION,U,3))
     30 I '$P(ACTION,U,5),$L($P(ACTION,U,4)) S:$P(ACTION,U,4)=0 CNT=CNT+1,@ORY@(CNT)="     Released by:       "_$$USER(+$P(ACTION,U,7))_" on "_$$DATE($P(ACTION,U,16)) S CNT=CNT+1,@ORY@(CNT)="     Signature:         "_$$SIG($P(ACTION,U,4)) ;186
     31 I $P(ACTION,U,9) S CNT=CNT+1,@ORY@(CNT)="     Nurse Verified:    "_$S($P(ACTION,U,8):$$USER(+$P(ACTION,U,8))_" on ",1:"")_$$DATE($P(ACTION,U,9))
     32 I $P(ACTION,U,11) S CNT=CNT+1,@ORY@(CNT)="     Clerk Verified:    "_$S($P(ACTION,U,10):$$USER(+$P(ACTION,U,10))_" on ",1:"")_$$DATE($P(ACTION,U,11))
     33 I $P(ACTION,U,19) S CNT=CNT+1,@ORY@(CNT)="     Chart Reviewed:    "_$S($P(ACTION,U,18):$$USER(+$P(ACTION,U,18))_" on ",1:"")_$$DATE($P(ACTION,U,19))
     34A3 I $P(ACTION,U,2)="DC",$L(OR6) S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)="     Reason for DC:     "_X
     35 I $L($G(^OR(100,ORIFN,8,ORI,1))) S X=^(1) D  ;add backdoor comments
     36 . N LBL,I S LBL=""
     37 . I $P(ACTION,U,15)="",$P(ACTION,U,2)'="DC" S LBL="     Comments:          " ;DC shown above
     38 . I $P(ACTION,U,15)=13,$P(ACTION,U,2)'="NW" S LBL="     Cancelled:         " ;NW shown in ORQ2
     39 . Q:'$L(LBL)  I $L(X)'>56 S CNT=CNT+1,@ORY@(CNT)=LBL_X Q
     40 . S DIWL=1,DIWR=56,DIWF="C56" K ^UTILITY($J,"W") D ^DIWP
     41 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=LBL_^(I,0),LBL="                        "
     42 I $D(^OR(100,ORIFN,8,ORI,5)) D  ;Ward comments
     43 . N X,ORJ K ^UTILITY($J,"W")
     44 . S ORJ=0 F  S ORJ=$O(^OR(100,ORIFN,8,ORI,5,ORJ)) Q:ORJ'>0  S X=^(ORJ,0) D ^DIWP
     45 . S ORJ=0 F  S ORJ=$O(^UTILITY($J,"W",DIWL,ORJ)) Q:ORJ'>0  S CNT=CNT+1,@ORY@(CNT)=$S(ORJ=1:"     Ward/Clinic Cmmts: ",1:"                        ")_^(ORJ,0)
     46 . K ^UTILITY($J,"W")
     47A4 I $P(ACTION,U,2)="HD",$G(^OR(100,ORIFN,8,ORI,2)) S X2=^(2),CNT=CNT+1,@ORY@(CNT)="     Hold Released:     "_$$FMTE^XLFDT($P(X2,U),"2P")_" by "_$$USER($P(X2,U,2))
     48 I $D(^OR(100,ORIFN,8,ORI,3)) D  ;Un-/Flagged
     49 . N X S X=$G(^OR(100,ORIFN,8,ORI,3))
     50 . S CNT=CNT+1,@ORY@(CNT)="     Flagged by:        "_$$USER(+$P(X,U,4))_" on "_$$DATE($P(X,U,3))
     51 . S CNT=CNT+1,@ORY@(CNT)="                        "_$P(X,U,5)
     52 . Q:X  S CNT=CNT+1,@ORY@(CNT)="     Unflagged by:      "_$$USER(+$P(X,U,7))_" on "_$$DATE($P(X,U,6))
     53 . S CNT=CNT+1,@ORY@(CNT)="                        "_$P(X,U,8)
     54 Q
     55 ;
     56DC ; -- Add Reason for DC
     57 S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(OR6,U,3))_$S($P(OR6,U,8):"  Auto-",1:"  ")_"Discontinued"
     58 I $P(OR6,U,8) D  Q
     59 . N EVT,PKG,ORV,I
     60 . S EVT=$P(OR6,U,8),PKG=$P($G(^ORE(100.2,+EVT,3,ORIFN,0)),U,2)
     61 . S @ORY@(CNT)=@ORY@(CNT)_" by "_$S(PKG="FH":"DIETETICS",PKG="LR":"LABORATORY",PKG="PS":"PHARMACY",1:"CPRS")
     62 . D EVENT(.ORV,1) S CNT=CNT+1,@ORY@(CNT)="     Patient Movement:  "_ORV(1)
     63 . S I=1 F  S I=$O(ORV(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I))
     64 I $P(OR6,U,2),$P($G(^ORD(100.02,+$P(OR6,U),0)),U,2)'="A" S @ORY@(CNT)=@ORY@(CNT)_" by "_$$USER($P(OR6,U,2)) ;don't show user name if auto-dc
     65 N X S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)="     Reason for DC:     "_X
     66 Q
     67 ;
     68ACTION(CODE) ; -- Return name of action CODE
     69 N NAME S NAME=$S(CODE="NW":"New Order",CODE="DC":"Discontinue",CODE="HD":"Hold",CODE="RL":"Release Hold",CODE="RN":"Renewal",CODE="XX":"Change",1:"")
     70 I CODE="NW",$P(OR3,U,11) S NAME=NAME_$S($P(OR3,U,11)=1:" (Change)",$P(OR3,U,11)=2:" (Renewal)",1:"")
     71 Q NAME
     72 ;
     73XACT(X) ; -- Return name of transaction code X
     74 N Y S X=$G(X)
     75 S Y=$S(X="XX":"Edited",X="DC":"Discontinued",X="HD":"Held",X="RL":"Hold Released",X="FW":"Forwarded",X="CA":"Cancelled",1:"")
     76 Q Y
     77 ;
     78DATE(X) ; -- Return date formatted as 00/00/0000 00:00
     79 N T,Y  S T=$P(X,".",2)_"0000"
     80 S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
     81 I T S Y=Y_" "_$E(T,1,2)_":"_$E(T,3,4)
     82 Q Y
     83 ;
     84USER(X) ; -- Returns NAME (TITLE) of New Person X
     85 N X0,Y S X0=$G(^VA(200,+X,0)),Y=$P(X0,U)
     86 S:$P(X0,U,9) Y=Y_" ("_$E($P($G(^DIC(3.1,+$P(X0,U,9),0)),U),1,15)_")"
     87 Q Y
     88 ;
     89SIG(X) ; -- Returns text of signature status X
     90 N Y S Y=""
     91 I X=0 S Y="ON CHART WITH WRITTEN ORDERS"
     92 I X=1 S Y="ELECTRONICALLY SIGNED"
     93 I X=2 S Y="NOT SIGNED"
     94 I X=3 S Y="NOT REQUIRED"
     95 I X=4 S Y="ON CHART WITH PRINTED ORDERS"
     96 I X=5 S Y="NOT REQUIRED DUE TO SERVICE CANCEL"
     97 I X=6 S Y="SERVICE CORRECTION TO SIGNED ORDER"
     98 Q Y
     99 ;
     100SERVCORR()      ; -- Returns 1 or 0, if current ACTION is a serv corr change
     101 N Y,NATURE,I,X S Y=0
     102 G:ORACT'="XX" SCQ
     103 S NATURE=+$P(ACTION,U,12),NATURE=$P($G(^ORD(100.02,NATURE,0)),U,2)
     104 I "^S^I^"'[(U_NATURE_U) G SCQ
     105 S I=$O(^OR(100,ORIFN,8,ORI),-1),X=$G(^(I,0))
     106 I $P(X,U,3)'=$P(ACTION,U,3),$P(X,U,5)'=$P(ACTION,U,3) G SCQ ;show prov
     107 S Y=1
     108SCQ Q Y
     109 ;
     110EVENT(ORTX,DC) ; -- Returns patient event info for EVT
     111 N EVT1,REL,X,Y,I,ORMAX
     112 S ORTX(1)="" ;177
     113 S EVT1=$G(^ORE(100.2,EVT,1)),REL=$G(^ORE(100.2,EVT,2,ORIFN,0))
     114 ; Return event data if AutoDC or auto-released by an event:
     115 I $G(DC)!(REL&'$L($P(REL,U,2))&($P(EVT1,U,2)!$P(EVT1,U,4))) D  Q
     116 . S Y=$S($P(EVT1,U,5):$P(EVT1,U,5),1:EVT) ;parent owns Activity
     117 . S Y=+$O(^ORE(100.2,+Y,10,0)),Y=$G(^(Y,0)),X=$P(Y,U,4) Q:'$L(X)
     118 . S X=$S(X="A":"ADMISSION",X="T":"TRANSFER",X="D":"DISCHARGE",X="S":"SPECIALTY CHANGE",1:"OUT OF O.R.")_" on "_$$DATE($P(EVT1,U))
     119 . S ORTX(1)=X,ORTX=1,ORMAX=56
     120 . I $P(Y,U,6) S X=$S($P(Y,U,4)="D":"from ",1:"to ")_$$GET1^DIQ(45.7,+$P(Y,U,6)_",",.01) D TXT^ORCHTAB
     121 . I $P(Y,U,7) S X="on "_$$GET1^DIQ(42,+$P(Y,U,7)_",",.01) D TXT^ORCHTAB
     122 S X=$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16))
     123 I ORIFN'=+$P($G(^ORE(100.2,EVT,0)),U,4),$P(REL,U,2)="MN" S X=X_" (manually released)"
     124 S ORTX(1)=X
     125 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ21.m

    r613 r623  
    1 ORQ21   ; SLC/MKB/GSS - Detailed Order Report cont ; 12/28/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,190,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 2400   OEL^PSOORRL   ^TMP("PS",$J)
    5         ; DBIA 2266   EN30^RAO7PC1  ^TMP($J,"RAE2")
    6         ;
    7 RAD(TCOM)       ; -- add RA data for 2.5 orders
    8         N RAIFN,CASE,PROC,ORD,ORI,X,ORTTL,ORB
    9         S RAIFN=$G(^OR(100,ORIFN,4)) Q:RAIFN'>0
    10         D EN30^RAO7PC1(RAIFN) Q:'$D(^TMP($J,"RAE2",+ORVP))  ;DBIA 2266
    11         S ORD=$G(^TMP($J,"RAE2",+ORVP,"ORD")),CASE=$O(^(0)) Q:'CASE  S PROC=$O(^(CASE,""))
    12         I '$G(TCOM) D  ;else add only Tech Comments
    13         . S CNT=CNT+1,@ORY@(CNT)=$$LJ^XLFSTR("Procedure:",30)_$S($L(ORD):ORD,1:PROC)
    14         . S ORI=0,ORTTL="Procedure Modifiers:          ",ORB=1
    15         . F  S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"M",ORI)) Q:ORI'>0  S CNT=CNT+1,@ORY@(CNT)=ORTTL_^(ORI),ORTTL=$$REPEAT^XLFSTR(" ",30)
    16         . S CNT=CNT+1,@ORY@(CNT)="History and Reason for Exam:"
    17         . F  S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"H",ORI)) Q:ORI'>0  S CNT=CNT+1,@ORY@(CNT)="  "_^(ORI)
    18 RAD1    I $L($G(^TMP($J,"RAE2",+ORVP,CASE,PROC,"TCOM",1))) S X=^(1) D
    19         . N DIWL,DIWR,DIWF,I K ^UTILITY($J,"W")
    20         . S DIWL=1,DIWR=72,DIWF="C72" D ^DIWP
    21         . S CNT=CNT+1,@ORY@(CNT)="Technologist's Comment:",ORB=1
    22         . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="  "_^(I,0)
    23         I $D(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM")) D
    24         . S ORTTL="Contrast Media used:          ",ORI=0,ORB=1
    25         . F  S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM",ORI)) Q:ORI<1  S CNT=CNT+1,@ORY@(CNT)=ORTTL_$P(^(ORI),U,2),ORTTL=$$REPEAT^XLFSTR(" ",30)
    26         K ^TMP($J,"RAE2",+ORVP),^UTILITY($J,"W")
    27         S:$G(ORB) CNT=CNT+1,@ORY@(CNT)="   " ;blank
    28         Q
    29         ;
    30 MED     ; -- Add Pharmacy order data
    31         Q:$G(^OR(100,ORIFN,4))["N"  ;non-VA med -- no refill history
    32         N TYPE,NODE,RXN,OR5,STAT S TYPE=$P(OR0,U,12)
    33         I '$D(^TMP("PS",$J,0)) D  ;get PS data / DBIA 2400
    34         . N PSIFN S PSIFN=$G(^OR(100,ORIFN,4))
    35         . S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"")
    36         . D OEL^PSOORRL(+ORVP,PSIFN_";"_TYPE)  ;DBIA 2400
    37         S NODE=$G(^TMP("PS",$J,0)),RXN=$G(^("RXN",0)),STAT=$P(NODE,U,6)
    38         I '$L(NODE) K ^TMP("PS",$J) Q  ;error
    39         I $O(^TMP("PS",$J,"DD",0)) D  ;Disp Drugs
    40         . N I,X,Y S X="Dispense Drugs (units/dose):  ",I=0
    41         . F  S I=$O(^TMP("PS",$J,"DD",I)) Q:I'>0  S Y=$G(^(I,0)) S:Y CNT=CNT+1,@ORY@(CNT)=X_$$GET1^DIQ(50,+Y_",",.01)_" ("_$P(Y,U,2)_")"
    42         S:$P(NODE,U,9) CNT=CNT+1,@ORY@(CNT)="Total Dose:                   "_$P(NODE,U,9)
    43 M1      I TYPE="I" D  ;admin data
    44         . N I,X,Y I $O(^TMP("PS",$J,"B",0)) D
    45         .. S X="IV Print Name:                ",I=0
    46         .. F  S I=$O(^TMP("PS",$J,"B",I)) Q:I<1  S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_$P(Y,U),X=$$REPEAT^XLFSTR(" ",30) I $L($P(Y,U,3)) S CNT=CNT+1,@ORY@(CNT)=X_" "_$P(Y,U,3)
    47         . S I=+$O(^TMP("PS",$J,"SCH",0)),X=$P($G(^(I,0)),U,2)
    48         . S:$L(X) CNT=CNT+1,@ORY@(CNT)="Schedule Type:                "_X
    49         . S X="Administration Times:         ",I=0
    50         . F  S I=$O(^TMP("PS",$J,"ADM",I)) Q:I'>0  S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30)
    51 M2      I TYPE="O" D  ;fill history
    52         . N FILLD,RET,X,Y,I
    53         . S:$P(NODE,U,12) CNT=CNT+1,@ORY@(CNT)="Last Filled:                  "_$$FMTE^XLFDT($P(NODE,U,12),2)
    54         . S CNT=CNT+1,@ORY@(CNT)="Refills Remaining:            "_$P(NODE,U,4)
    55         . I $P(RXN,U,6)!$G(^TMP("PS",$J,"REF",0)) S X="Filled:                       " D
    56         .. I $P(RXN,U,6) S FILLD=$P(RXN,U,6)_"^^^"_$P(RXN,U,7)_U_$P(RXN,U,3,4) D FILLED("R")
    57         .. S RET=$G(^TMP("PS",$J,"RXN","RSTC")) I RET'="" D RETURNS(RET)
    58         .. S I=0 F  S I=$O(^TMP("PS",$J,"REF",I)) Q:I'>0  D
    59         ... S FILLD=$G(^(I,0)) D FILLED("R")
    60         ... S RET=$G(^TMP("PS",$J,"REF",I,"RSTC")) I RET'="" D RETURNS(RET)
    61         . I $G(^TMP("PS",$J,"PAR",0)) S I=0,X="Partial Fills:      " F  S I=$O(^TMP("PS",$J,"PAR",I)) Q:I'>0  S FILLD=$G(^(I,0)) D FILLED("P")
    62         . S:RXN CNT=CNT+1,@ORY@(CNT)="Prescription#:                "_$P(RXN,U)
    63 M3      S:$P(RXN,U,5) CNT=CNT+1,@ORY@(CNT)="Pharmacist:                   "_$P($G(^VA(200,+$P(RXN,U,5),0)),U)
    64            I $G(STAT)="ACTIVE/SUSP" S CNT=CNT+1,@ORY@(CNT)="Prescription Status:          "_STAT_" - Order is active. Fill or Refill has been requested."
    65         S:$P(NODE,U,13) CNT=CNT+1,@ORY@(CNT)="NOT TO BE GIVEN" K ^TMP("PS",$J)
    66         S CNT=CNT+1,@ORY@(CNT)="   " ;blank
    67         S OR5=$G(^OR(100,ORIFN,5)) I $L(OR5) D  ;SC data
    68         . N X,Y,I
    69         . S CNT=CNT+1,@ORY@(CNT)="   " ;blank line
    70         . S CNT=CNT+1,@ORY@(CNT)="First Party Pay Exemptions"
    71         . S X="For conditions related to:    "
    72         . F I=1:1:8 S Y=$P(OR5,U,I) I Y S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30)
    73         Q
    74         ;
    75 BA      ;Billing Aware data display
    76         N DXIEN,DXV,ICD9,ICDR,OCT,ORFMDAT
    77         S OCT=0,X=""
    78         ; Get the date of the order for CSV/CTD usage
    79         S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN)
    80         ; $O through diagnoses for an order
    81         F  S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N  D
    82         . ; DXIEN=Dx IEN
    83         . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0)
    84         . ; Get Dx record for date ORFMDAT
    85         . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT)
    86         . ; Get Dx verbiage and ICD code
    87         . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2)
    88         . S X="               "
    89         . I OCT=1 D
    90         .. S CNT=CNT+1,@ORY@(CNT)="   " ;blank line
    91         .. S CNT=CNT+1,@ORY@(CNT)="Clinical Indicators"
    92         .. S X="Diagnosis of:  "
    93         . S X=X_ICD9_" - "_DXV,CNT=CNT+1,@ORY@(CNT)=X
    94         I OCT'="" D  ;if there are diagnoses show Treatment Factors
    95         . S X="For conditions related to:    "
    96         . F I=1:1:8 S Y=$P(^OR(100,ORIFN,5.2),U,I) I Y D
    97         .. S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30)
    98         Q
    99         ;
    100 FILLED(TYPE)    ; -- add FILLD data
    101         N Y S Y=$$FMTE^XLFDT($P(FILLD,U),2)_" ("_$$ROUTING($P(FILLD,U,5))_")"
    102         S:TYPE="R"&$P(FILLD,U,4) Y=Y_" released "_$$FMTE^XLFDT($P(FILLD,U,4),2)
    103         S:TYPE="P"&$P(FILLD,U,3) Y=Y_" Qty: "_$P(FILLD,U,3)
    104         S CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30)
    105         S:$L($P(FILLD,U,6)) CNT=CNT+1,@ORY@(CNT)=X_$P(FILLD,U,6)
    106         Q
    107 RETURNS(NODE)   ; add Return to Stock Data
    108         N DATE,NAME,TEXT,X
    109         S DATE=$$FMTE^XLFDT($P(NODE,U))
    110         S NAME=$P(^VA(200,$P(NODE,U,2),0),U)
    111         S X=$$REPEAT^XLFSTR(" ",13)
    112         S TEXT="Return to Stock: "_X_DATE_" by "_NAME
    113         S CNT=CNT+1,@ORY@(CNT)=TEXT
    114         S X=$$REPEAT^XLFSTR(" ",30)
    115         S TEXT=X_"Comments: "_$P(NODE,U,3)
    116         S CNT=CNT+1,@ORY@(CNT)=TEXT
    117         Q
    118         ;
    119 ROUTING(X)      ; -- Returns external form
    120         N Y S Y=$S($G(X)="M":"Mail",$G(X)="W":"Window",1:$G(X))
    121         Q Y
    122         ;
    123 SC(J)   ; -- Returns name of SC field by piece number
    124         I '$G(J) Q ""
    125         I J=1 Q "SERVICE CONNECTED CONDITION"
    126         I J=2 Q "MILITARY SEXUAL TRAUMA"
    127         I J=3 Q "AGENT ORANGE EXPOSURE"
    128         I J=4 Q "IONIZING RADIATION EXPOSURE"
    129         I J=5 Q "ENVIRONMENTAL CONTAMINANTS"
    130         I J=6 Q "HEAD OR NECK CANCER"
    131         I J=7 Q "COMBAT VETERAN"
    132         I J=8 Q "SHIPBOARD HAZARD AND DEFENSE"
    133         Q ""
     1ORQ21 ; SLC/MKB/GSS - Detailed Order Report cont ; 10/6/2005
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,190,195,215**;Dec 17, 1997
     3 ;
     4 ; DBIA 2400   OEL^PSOORRL   ^TMP("PS",$J)
     5 ; DBIA 2266   EN30^RAO7PC1  ^TMP($J,"RAE2")
     6 ;
     7RAD(TCOM) ; -- add RA data for 2.5 orders
     8 N RAIFN,CASE,PROC,ORD,ORI,X,ORTTL,ORB
     9 S RAIFN=$G(^OR(100,ORIFN,4)) Q:RAIFN'>0
     10 D EN30^RAO7PC1(RAIFN) Q:'$D(^TMP($J,"RAE2",+ORVP))  ;DBIA 2266
     11 S ORD=$G(^TMP($J,"RAE2",+ORVP,"ORD")),CASE=$O(^(0)) Q:'CASE  S PROC=$O(^(CASE,""))
     12 I '$G(TCOM) D  ;else add only Tech Comments
     13 . S CNT=CNT+1,@ORY@(CNT)=$$LJ^XLFSTR("Procedure:",30)_$S($L(ORD):ORD,1:PROC)
     14 . S ORI=0,ORTTL="Procedure Modifiers:          ",ORB=1
     15 . F  S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"M",ORI)) Q:ORI'>0  S CNT=CNT+1,@ORY@(CNT)=ORTTL_^(ORI),ORTTL=$$REPEAT^XLFSTR(" ",30)
     16 . S CNT=CNT+1,@ORY@(CNT)="History and Reason for Exam:"
     17 . F  S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"H",ORI)) Q:ORI'>0  S CNT=CNT+1,@ORY@(CNT)="  "_^(ORI)
     18RAD1 I $L($G(^TMP($J,"RAE2",+ORVP,CASE,PROC,"TCOM",1))) S X=^(1) D
     19 . N DIWL,DIWR,DIWF,I K ^UTILITY($J,"W")
     20 . S DIWL=1,DIWR=72,DIWF="C72" D ^DIWP
     21 . S CNT=CNT+1,@ORY@(CNT)="Technologist's Comment:",ORB=1
     22 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="  "_^(I,0)
     23 I $D(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM")) D
     24 . S ORTTL="Contrast Media used:          ",ORI=0,ORB=1
     25 . F  S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM",ORI)) Q:ORI<1  S CNT=CNT+1,@ORY@(CNT)=ORTTL_$P(^(ORI),U,2),ORTTL=$$REPEAT^XLFSTR(" ",30)
     26 K ^TMP($J,"RAE2",+ORVP),^UTILITY($J,"W")
     27 S:$G(ORB) CNT=CNT+1,@ORY@(CNT)="   " ;blank
     28 Q
     29 ;
     30MED ; -- Add Pharmacy order data
     31 Q:$G(^OR(100,ORIFN,4))["N"  ;non-VA med -- no refill history
     32 N TYPE,NODE,RXN,OR5,STAT S TYPE=$P(OR0,U,12)
     33 I '$D(^TMP("PS",$J,0)) D  ;get PS data / DBIA 2400
     34 . N PSIFN S PSIFN=$G(^OR(100,ORIFN,4))
     35 . S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"")
     36 . D OEL^PSOORRL(+ORVP,PSIFN_";"_TYPE)  ;DBIA 2400
     37 S NODE=$G(^TMP("PS",$J,0)),RXN=$G(^("RXN",0)),STAT=$P(NODE,U,6)
     38 I '$L(NODE) K ^TMP("PS",$J) Q  ;error
     39 I $O(^TMP("PS",$J,"DD",0)) D  ;Disp Drugs
     40 . N I,X,Y S X="Dispense Drugs (units/dose):  ",I=0
     41 . F  S I=$O(^TMP("PS",$J,"DD",I)) Q:I'>0  S Y=$G(^(I,0)) S:Y CNT=CNT+1,@ORY@(CNT)=X_$$GET1^DIQ(50,+Y_",",.01)_" ("_$P(Y,U,2)_")"
     42 S:$P(NODE,U,9) CNT=CNT+1,@ORY@(CNT)="Total Dose:                   "_$P(NODE,U,9)
     43M1 I TYPE="I" D  ;admin data
     44 . N I,X,Y I $O(^TMP("PS",$J,"B",0)) D
     45 .. S X="IV Print Name:                ",I=0
     46 .. F  S I=$O(^TMP("PS",$J,"B",I)) Q:I<1  S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_$P(Y,U),X=$$REPEAT^XLFSTR(" ",30) I $L($P(Y,U,3)) S CNT=CNT+1,@ORY@(CNT)=X_" "_$P(Y,U,3)
     47 . S I=+$O(^TMP("PS",$J,"SCH",0)),X=$P($G(^(I,0)),U,2)
     48 . S:$L(X) CNT=CNT+1,@ORY@(CNT)="Schedule Type:                "_X
     49 . S X="Administration Times:         ",I=0
     50 . F  S I=$O(^TMP("PS",$J,"ADM",I)) Q:I'>0  S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30)
     51M2 I TYPE="O" D  ;fill history
     52 . N FILLD,X,Y,I
     53 . S:$P(NODE,U,12) CNT=CNT+1,@ORY@(CNT)="Last Filled:                  "_$$FMTE^XLFDT($P(NODE,U,12),2)
     54 . S CNT=CNT+1,@ORY@(CNT)="Refills Remaining:            "_$P(NODE,U,4)
     55 . I $P(RXN,U,6)!$G(^TMP("PS",$J,"REF",0)) S X="Filled:                       " D
     56 .. I $P(RXN,U,6) S FILLD=$P(RXN,U,6)_"^^^"_$P(RXN,U,7)_U_$P(RXN,U,3,4) D FILLED("R")
     57 .. S I=0 F  S I=$O(^TMP("PS",$J,"REF",I)) Q:I'>0  S FILLD=$G(^(I,0)) D FILLED("R")
     58 . I $G(^TMP("PS",$J,"PAR",0)) S I=0,X="Partial Fills:      " F  S I=$O(^TMP("PS",$J,"PAR",I)) Q:I'>0  S FILLD=$G(^(I,0)) D FILLED("P")
     59 . S:RXN CNT=CNT+1,@ORY@(CNT)="Prescription#:                "_$P(RXN,U)
     60M3 S:$P(RXN,U,5) CNT=CNT+1,@ORY@(CNT)="Pharmacist:                   "_$P($G(^VA(200,+$P(RXN,U,5),0)),U)
     61    I $G(STAT)="ACTIVE/SUSP" S CNT=CNT+1,@ORY@(CNT)="Prescription Status:          "_STAT_" - Order is active. Fill or Refill has been requested."
     62 S:$P(NODE,U,13) CNT=CNT+1,@ORY@(CNT)="NOT TO BE GIVEN" K ^TMP("PS",$J)
     63 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
     64 S OR5=$G(^OR(100,ORIFN,5)) I $L(OR5) D  ;SC data
     65 . N X,Y,I
     66 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank line
     67 . S CNT=CNT+1,@ORY@(CNT)="First Party Pay Exemptions"
     68 . S X="For conditions related to:    "
     69 . F I=1:1:7 S Y=$P(OR5,U,I) I Y S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30)
     70 Q
     71 ;
     72BA ;Billing Aware data display
     73 N DXIEN,DXV,ICD9,ICDR,OCT,ORFMDAT
     74 S OCT=0,X=""
     75 ; Get the date of the order for CSV/CTD usage
     76 S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN)
     77 ; $O through diagnoses for an order
     78 F  S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N  D
     79 . ; DXIEN=Dx IEN
     80 . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0)
     81 . ; Get Dx record for date ORFMDAT
     82 . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT)
     83 . ; Get Dx verbiage and ICD code
     84 . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2)
     85 . S X="               "
     86 . I OCT=1 D
     87 .. S CNT=CNT+1,@ORY@(CNT)="   " ;blank line
     88 .. S CNT=CNT+1,@ORY@(CNT)="Clinical Indicators"
     89 .. S X="Diagnosis of:  "
     90 . S X=X_ICD9_" - "_DXV,CNT=CNT+1,@ORY@(CNT)=X
     91 I OCT'="" D  ;if there are diagnoses show Treatment Factors
     92 . S X="For conditions related to:    "
     93 . F I=1:1:7 S Y=$P(^OR(100,ORIFN,5.2),U,I) I Y D
     94 .. S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30)
     95 Q
     96 ;
     97FILLED(TYPE) ; -- add FILLD data
     98 N Y S Y=$$FMTE^XLFDT($P(FILLD,U),2)_" ("_$$ROUTING($P(FILLD,U,5))_")"
     99 S:TYPE="R"&$P(FILLD,U,4) Y=Y_" released "_$$FMTE^XLFDT($P(FILLD,U,4),2)
     100 S:TYPE="P"&$P(FILLD,U,3) Y=Y_" Qty: "_$P(FILLD,U,3)
     101 S CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30)
     102 S:$L($P(FILLD,U,6)) CNT=CNT+1,@ORY@(CNT)=X_$P(FILLD,U,6)
     103 Q
     104 ;
     105ROUTING(X) ; -- Returns external form
     106 N Y S Y=$S($G(X)="M":"Mail",$G(X)="W":"Window",1:$G(X))
     107 Q Y
     108 ;
     109SC(J) ; -- Returns name of SC field by piece number
     110 I '$G(J) Q ""
     111 I J=1 Q "SERVICE CONNECTED CONDITION"
     112 I J=2 Q "MILITARY SEXUAL TRAUMA"
     113 I J=3 Q "AGENT ORANGE EXPOSURE"
     114 I J=4 Q "IONIZING RADIATION EXPOSURE"
     115 I J=5 Q "ENVIRONMENTAL CONTAMINANTS"
     116 I J=6 Q "HEAD OR NECK CANCER"
     117 I J=7 Q "COMBAT VETERAN"
     118 Q ""

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPT.m

    r613 r623  
    1 ORQPT   ; SLC/MKB - Patient Selection ; 4/18/07 7:20am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**52,82,85,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; Ref. to ^UTILITY via IA 10061
    5         ; SLC/PKS - 3/2000: Modified to deal with "Combinations."
    6         ;
    7 EN      ; -- main entry point for OR PATIENT SELECTION
    8         I $G(ORVP),'($D(ORPNM)&$D(ORSSN)) K ORVP ; reset
    9         D EN^VALM("OR PATIENT SELECTION")
    10         Q
    11         ;
    12 HDR     ; -- header code
    13         N X I '$G(ORVP) S X="** No patient selected **"
    14         E  S X=$G(ORPNM)_"   "_$G(ORSSN)
    15         S VALMHDR(1)="Current patient: "_X
    16         Q
    17         ;
    18 INIT    ; -- init variables and list array
    19         ; Modifications for multiple "Combination" lists by PKS.
    20         ;
    21         ; PARAM herein might end up as: ORLP DEFAULT CLINIC WEDNESDAY
    22         ;    (Param Name and current DOW)
    23         ; ORY might end up passed as:  5^5^C;1;T-360;T+60;A
    24         ;    (#lines^#pts^source;serviceSection;startDate;stopDate;sort)
    25         ;
    26         N ORY,ORX,PARAM,ORYZB,ORYZE
    27         ;
    28         ;added by CLA 12/12/96 - gets SERVICE/SECTION of user:
    29         N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
    30         ;
    31         S ORY=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),"ORLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user.
    32         I $L(ORY) D  S ORY=ORY_";"_ORX
    33         . ; PKS: Set "PARAM" var to parameter name in param def file:
    34         . S PARAM="ORLP DEFAULT "_$S(ORY="T":"TEAM",ORY="S":"SPECIALTY",ORY="P":"PROVIDER",ORY="W":"WARD",ORY="C":"CLINIC",ORY="M":"COMBINATION",1:"")
    35         . S:ORY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW.
    36         . S ORX=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),PARAM,1,"I") ; Source param.
    37         . ; Next lines modified by PKS for "Combinations" and dates:
    38         . I (ORY="C")!(ORY="M") D
    39         . . S ORYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date.
    40         . . I ORYZB="T+0" S ORYZB=$$FMTE^XLFDT(DT,ORYZB)
    41         . . S ORX=ORX_";"_ORYZB
    42         . . S ORYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date.
    43         . . I ORYZE="T+0" S ORYZE=$$FMTE^XLFDT(DT,ORYZE)
    44         . . S ORX=ORX_";"_ORYZE
    45         S $P(ORY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") ; Add default sort order.
    46         ;
    47         ; Call tag that builds the actual Patient Selection List:
    48         D BUILD(ORY)
    49         Q
    50         ;
    51 DEFAULT()       ; -- Returns default action
    52         I '$P($G(^TMP("OR",$J,"PATIENTS",0)),U,2) Q "Change View"
    53         I XQORM("B")="Quit" Q "Close"
    54         Q "Next Screen"
    55         ;
    56 MSG()   ; -- Lmgr msg bar
    57         Q "Enter the number of the patient chart to be opened"
    58         ;
    59 HELP    ; -- help code
    60         N X D FULL^VALM1 S VALMBCK="R"
    61         W !!,"Enter the display number of the patient whose chart you wish to open"
    62         W !,"or enter a patient name, SSN, or initial/last 4 combination.  To"
    63         W !,"change the list of patients displayed on this screen, enter CV.  To"
    64         W !,"have the new list automatically displayed when selecting a new patient,"
    65         W !,"enter SV.  Enter FD to search by patient name or identifier."
    66         W !!,"Press <return> to continue ..." R X:DTIME
    67         Q
    68         ;
    69 EXIT    ; -- exit code
    70         K ^TMP("OR",$J,"PATIENTS"),XQORM("ALT")
    71         Q
    72         ;
    73 BUILD(LIST)     ; -- build list in ^TMP("OR",$J,"PATIENTS")
    74         N ORI,ORX,ORY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS
    75         S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5)
    76         ; Next 5 lines added by PKS:
    77         I ((SORT="S")&(TYPE'="M")) S SORT="A"    ; Reset invalid sorts.
    78         I TYPE="M" D                             ; Deal with combinations.
    79         .I ((SORT="P")!(SORT="A")!(SORT="S")) Q  ; P,A,S are acceptable.
    80         .S SORT="A"                              ; Default.
    81         S $P(LIST,";",5)=SORT                    ; Reset in case of change.
    82         S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y
    83         S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y
    84         I TYPE="T" D TEAMPTS^ORQPTQ1(.ORY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U)
    85         I TYPE="P" D PROVPTS^ORQPTQ2(.ORY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U)
    86         I TYPE="S" D SPECPTS^ORQPTQ2(.ORY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U)
    87         I TYPE="W" D WARDPTS^ORQPTQ2(.ORY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U)
    88         I TYPE="C" D CLINPTS^ORQPTQ2(.ORY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U)
    89         ; Next line added by PKS for "Combinations:"
    90         I TYPE="M" N MSG D COMBPTS^ORQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("OR",$J,"PATIENTS").
    91         ; Next section added by PKS for "Combinations:"
    92         I TYPE="M" D  G BQ    ; Check MSG var, then go to BQ tag.
    93         .I MSG'="" D          ; Did call to COMBPTS assign an error message?
    94         ..S LCNT=1,NUM=0      ; Set defaults.
    95         ..S ^TMP("OR",$J,"PATIENTS",1,0)="     "_MSG ; Write error msg.
    96         D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1.
    97         ;
    98 B1      S ORI=0 F  S ORI=$O(ORY(ORI)) Q:ORI'>0  I ORY(ORI) D  ; sort
    99         . S DFN=+ORY(ORI)
    100         . ;sort logic added by CLA 7/23/97:
    101         . S ORX=""
    102         . I SORT="P",(TYPE="C") S ORX=$P($G(ORY(ORI)),U,4) D
    103         .. S $P(ORX,".",2)=$E($P(ORX,".",2)_"000",1,4)
    104         ..S ORX=ORX_U_$P(ORY(ORI),U,2)
    105         . I SORT="R",(TYPE'="C") S ORX=$P($G(^DPT(+ORY(ORI),.101)),U)_U_$P(ORY(ORI),U,2)
    106         . I SORT="T" S ORX="" ; Need to add terminal digit sorting.
    107         . ; If no sort specified, default to alphabetic (plus app't if clinic type):
    108         . I ORX="" S ORX=$P(ORY(ORI),U,2)_U_$P($G(ORY(ORI)),U,4)
    109         . S ^TMP("OR",$J,"PATIENTS","B",ORX_DFN)=ORY(ORI) ; DFN ^ Name
    110         I '$D(^TMP("OR",$J,"PATIENTS")) D  G BQ
    111         . N MSG
    112         . S MSG="No patients found"
    113         . S LCNT=1,NUM=0
    114         . I $D(ORY(1)) S MSG=$P(ORY(1),"^",2) ; error message from search
    115         . S ^TMP("OR",$J,"PATIENTS",1,0)="     "_MSG
    116 B2      S ORX="" F  S ORX=$O(^TMP("OR",$J,"PATIENTS","B",ORX)) Q:ORX=""  S ORY=^(ORX) D
    117         . S DFN=+ORY,NAME=$P(ORY,U,2)
    118         . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3))
    119         . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U)
    120         . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(ORX,U)),1:$$FMTE^XLFDT($P(^TMP("OR",$J,"PATIENTS","B",ORX),U,4)))
    121         . ;Q:RBED=""  removed by CLA 7/23/97 to prevent blank lines
    122         . S LCNT=LCNT+1,NUM=NUM+1
    123         . S ^TMP("OR",$J,"PATIENTS","IDX",NUM)=ORY ; DFN ^ NAME
    124         . ; Next lines modified/added by PKS on 1/24/2001:
    125         . ; Check for "sensitive" patients:
    126         . S PTID=""
    127         . S PTID=$$ID(DFN)
    128         . S SENS=$$SSN^DPTLK1(DFN)
    129         . I SENS["*" S PTID=""
    130         . S DOB=$$DOB^DPTLK1(DFN)
    131         . S ^TMP("OR",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED)
    132         . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM)
    133 BQ      S ^TMP("OR",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context
    134         S ^TMP("OR",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM
    135         S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source   Other",1:"Room-Bed")
    136         D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR
    137         S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE
    138         Q
    139         ;
    140 ID(DFN) ; -- Returns short ID for patient ID
    141         N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID
    142         I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN
    143         Q "("_$E(NAME)_ID_")"
    144         ;
    145 APPT(DFN,CLINIC,FROM,TO)        ; -- Return [next?] clinic appointment
    146         ; returns date/time next appt or "", returns "^error message" on error
    147         N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J)  ;IA 10061
    148         S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)=""
    149         D SDA^ORQRY01(.ERR,.ERRMSG)
    150         I ERR K ^UTILITY("VASD",$J) Q ERRMSG
    151         S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U)
    152         K ^UTILITY("VASD",$J)
    153         Q NEXT
    154         ;
    155 ALT     ; -- XQORM("ALT") code to search File 2 for patient X
    156         N DIC,DFN,Y,ORX S ORX=X D FULL^VALM1
    157         S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:ORX)
    158         D ^DIC I Y'>0 S VALMBCK="R" Q  ;S XQORMERR=1 Q
    159         S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q
    160         S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables
    161         Q
    162         ;
    163 FIND    ; -- find patient in ^DPT
    164         N X,Y,DIC,ORX,DFN
    165         S DIC=2,DIC(0)="AEQM" D FULL^VALM1
    166         D ^DIC I Y'>0 S VALMBCK="R" Q
    167         S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q
    168         S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables
    169         Q
    170         ;
    171 SELECT  ; -- select patient from list
    172         N NMBR,X,Y,Z,DIC,DFN,ORX S NMBR=+$P(XQORNOD(0),"=",2)
    173         S Y=$G(^TMP("OR",$J,"PATIENTS","IDX",NMBR)),DFN=+Y
    174         I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q
    175         ;W "   "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN
    176         D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q
    177         S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q
    178 SLCT1   ; -- may enter here with DFN from FIND
    179         N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV
    180         D OERR^VADPT,ELIG^VADPT
    181         S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D
    182         . I $G(NMBR) N X S X=$$CONTEXT^ORQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC  ; use clinic if selected from list, else ask
    183         . S LOC="" ;,X=$$LOCATION^ORCMENU1(1) S:X LOC=X
    184         S ORL=LOC,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)=VAIN(5)
    185         S ORVP=DFN_";DPT(",ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2)
    186         S ORDOB=$P(VADM(3),U,2),ORAGE=VADM(4),ORSEX=$P(VADM(5),U)
    187         S ORTS=+VAIN(3),ORWARD=VAIN(4),ORATTEND=+VAIN(11),ORSC=$G(VAEL(3))
    188         I $P($G(^DGSL(38.1,+ORVP,0)),"^",2),($G(^DPT(+ORVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D
    189         . ; if senstive patient and (patient inpatient or user holds key)
    190         . ; prevents sensitive patient warning from scrolling off screen
    191         . N X
    192         . W !!,"Press <return> to continue ..."
    193         . R X:DTIME
    194 SLCT2   ; -- convert patient's orders, if not already done
    195         Q
    196         ;
    197 OK(DATE)        ; -- Patient is deceased; ok to continue?
    198         N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
    199         S DIR("A")="Do you wish to continue? "
    200         W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!"
    201         D ^DIR
    202         Q +Y
     1ORQPT ; SLC/MKB - Patient Selection ;3/16/05  08:28
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**52,82,85,215**;Dec 17, 1997
     3 ;
     4 ; Ref. to ^UTILITY via IA 10061
     5 ; SLC/PKS - 3/2000: Modified to deal with "Combinations."
     6 ;
     7EN ; -- main entry point for OR PATIENT SELECTION
     8 I $G(ORVP),'($D(ORPNM)&$D(ORSSN)) K ORVP ; reset
     9 D EN^VALM("OR PATIENT SELECTION")
     10 Q
     11 ;
     12HDR ; -- header code
     13 N X I '$G(ORVP) S X="** No patient selected **"
     14 E  S X=$G(ORPNM)_"   "_$G(ORSSN)
     15 S VALMHDR(1)="Current patient: "_X
     16 Q
     17 ;
     18INIT ; -- init variables and list array
     19 ; Modifications for multiple "Combination" lists by PKS.
     20 ;
     21 ; PARAM herein might end up as: ORLP DEFAULT CLINIC WEDNESDAY
     22 ;    (Param Name and current DOW)
     23 ; ORY might end up passed as:  5^5^C;1;T-360;T+60;A
     24 ;    (#lines^#pts^source;serviceSection;startDate;stopDate;sort)
     25 ;
     26 N ORY,ORX,PARAM,ORYZB,ORYZE
     27 ;
     28 ;added by CLA 12/12/96 - gets SERVICE/SECTION of user:
     29 N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
     30 ;
     31 S ORY=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),"ORLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user.
     32 I $L(ORY) D  S ORY=ORY_";"_ORX
     33 . ; PKS: Set "PARAM" var to parameter name in param def file:
     34 . S PARAM="ORLP DEFAULT "_$S(ORY="T":"TEAM",ORY="S":"SPECIALTY",ORY="P":"PROVIDER",ORY="W":"WARD",ORY="C":"CLINIC",ORY="M":"COMBINATION",1:"")
     35 . S:ORY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW.
     36 . S ORX=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),PARAM,1,"I") ; Source param.
     37 . ; Next lines modified by PKS for "Combinations" and dates:
     38 . I (ORY="C")!(ORY="M") D
     39 . . S ORYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date.
     40 . . I ORYZB="T+0" S ORYZB=$$FMTE^XLFDT(DT,ORYZB)
     41 . . S ORX=ORX_";"_ORYZB
     42 . . S ORYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date.
     43 . . I ORYZE="T+0" S ORYZE=$$FMTE^XLFDT(DT,ORYZE)
     44 . . S ORX=ORX_";"_ORYZE
     45 S $P(ORY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") ; Add default sort order.
     46 ;
     47 ; Call tag that builds the actual Patient Selection List:
     48 D BUILD(ORY)
     49 Q
     50 ;
     51DEFAULT() ; -- Returns default action
     52 I '$P($G(^TMP("OR",$J,"PATIENTS",0)),U,2) Q "Change View"
     53 I XQORM("B")="Quit" Q "Close"
     54 Q "Next Screen"
     55 ;
     56MSG() ; -- Lmgr msg bar
     57 Q "Enter the number of the patient chart to be opened"
     58 ;
     59HELP ; -- help code
     60 N X D FULL^VALM1 S VALMBCK="R"
     61 W !!,"Enter the display number of the patient whose chart you wish to open"
     62 W !,"or enter a patient name, SSN, or initial/last 4 combination.  To"
     63 W !,"change the list of patients displayed on this screen, enter CV.  To"
     64 W !,"have the new list automatically displayed when selecting a new patient,"
     65 W !,"enter SV.  Enter FD to search by patient name or identifier."
     66 W !!,"Press <return> to continue ..." R X:DTIME
     67 Q
     68 ;
     69EXIT ; -- exit code
     70 K ^TMP("OR",$J,"PATIENTS"),XQORM("ALT")
     71 Q
     72 ;
     73BUILD(LIST) ; -- build list in ^TMP("OR",$J,"PATIENTS")
     74 N ORI,ORX,ORY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS
     75 S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5)
     76 ; Next 5 lines added by PKS:
     77 I ((SORT="S")&(TYPE'="M")) S SORT="A"    ; Reset invalid sorts.
     78 I TYPE="M" D                             ; Deal with combinations.
     79 .I ((SORT="P")!(SORT="A")!(SORT="S")) Q  ; P,A,S are acceptable.
     80 .S SORT="A"                              ; Default.
     81 S $P(LIST,";",5)=SORT                    ; Reset in case of change.
     82 S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y
     83 S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y
     84 I TYPE="T" D TEAMPTS^ORQPTQ1(.ORY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U)
     85 I TYPE="P" D PROVPTS^ORQPTQ2(.ORY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U)
     86 I TYPE="S" D SPECPTS^ORQPTQ2(.ORY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U)
     87 I TYPE="W" D WARDPTS^ORQPTQ2(.ORY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U)
     88 I TYPE="C" D CLINPTS^ORQPTQ2(.ORY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U)
     89 ; Next line added by PKS for "Combinations:"
     90 I TYPE="M" N MSG D COMBPTS^ORQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("OR",$J,"PATIENTS").
     91 ; Next section added by PKS for "Combinations:"
     92 I TYPE="M" D  G BQ    ; Check MSG var, then go to BQ tag.
     93 .I MSG'="" D          ; Did call to COMBPTS assign an error message?
     94 ..S LCNT=1,NUM=0      ; Set defaults.
     95 ..S ^TMP("OR",$J,"PATIENTS",1,0)="     "_MSG ; Write error msg.
     96 D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1.
     97 ;
     98B1 S ORI=0 F  S ORI=$O(ORY(ORI)) Q:ORI'>0  I ORY(ORI) D  ; sort
     99 . S DFN=+ORY(ORI)
     100 . ;sort logic added by CLA 7/23/97:
     101 . S ORX=""
     102 . I SORT="P",(TYPE="C") S ORX=$P($G(ORY(ORI)),U,4) D
     103 .. S $P(ORX,".",2)=$E($P(ORX,".",2)_"000",1,4)
     104 ..S ORX=ORX_U_$P(ORY(ORI),U,2)
     105 . I SORT="R",(TYPE'="C") S ORX=$P($G(^DPT(+ORY(ORI),.101)),U)_U_$P(ORY(ORI),U,2)
     106 . I SORT="T" S ORX="" ; Need to add terminal digit sorting.
     107 . ; If no sort specified, default to alphabetic (plus app't if clinic type):
     108 . I ORX="" S ORX=$P(ORY(ORI),U,2)_U_$P($G(ORY(ORI)),U,4)
     109 . S ^TMP("OR",$J,"PATIENTS","B",ORX_DFN)=ORY(ORI) ; DFN ^ Name
     110 I '$D(^TMP("OR",$J,"PATIENTS")) D  G BQ
     111 . N MSG
     112 . S MSG="No patients found"
     113 . S LCNT=1,NUM=0
     114 . I $D(ORY(1)) S MSG=$P(ORY(1),"^",2) ; error message from search
     115 . S ^TMP("OR",$J,"PATIENTS",1,0)="     "_MSG
     116B2 S ORX="" F  S ORX=$O(^TMP("OR",$J,"PATIENTS","B",ORX)) Q:ORX=""  S ORY=^(ORX) D
     117 . S DFN=+ORY,NAME=$P(ORY,U,2)
     118 . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3))
     119 . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U)
     120 . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(ORX,U)),1:$$FMTE^XLFDT($P(^TMP("OR",$J,"PATIENTS","B",ORX),U,4)))
     121 . ;Q:RBED=""  removed by CLA 7/23/97 to prevent blank lines
     122 . S LCNT=LCNT+1,NUM=NUM+1
     123 . S ^TMP("OR",$J,"PATIENTS","IDX",NUM)=ORY ; DFN ^ NAME
     124 . ; Next lines modified/added by PKS on 1/24/2001:
     125 . ; Check for "sensitive" patients:
     126 . S PTID=""
     127 . S PTID=$$ID(DFN)
     128 . S SENS=$$SSN^DPTLK1(DFN)
     129 . I SENS["*" S PTID=""
     130 . S DOB=$$DOB^DPTLK1(DFN)
     131 . S ^TMP("OR",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED)
     132 . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM)
     133BQ S ^TMP("OR",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context
     134 S ^TMP("OR",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM
     135 S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source   Other",1:"Room-Bed")
     136 D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR
     137 S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE
     138 Q
     139 ;
     140ID(DFN) ; -- Returns short ID for patient ID
     141 N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID
     142 I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN
     143 Q "("_$E(NAME)_ID_")"
     144 ;
     145APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment
     146 ; returns date/time next appt or "", returns "^error message" on error
     147 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J)  ;IA 10061
     148 S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)=""
     149 D SDA^ORQRY01(.ERR,.ERRMSG)
     150 I ERR K ^UTILITY("VASD",$J) Q ERRMSG
     151 S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U)
     152 K ^UTILITY("VASD",$J)
     153 Q NEXT
     154 ;
     155ALT ; -- XQORM("ALT") code to search File 2 for patient X
     156 N DIC,DFN,Y,ORX S ORX=X D FULL^VALM1
     157 S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:ORX)
     158 D ^DIC I Y'>0 S VALMBCK="R" Q  ;S XQORMERR=1 Q
     159 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q
     160 S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables
     161 Q
     162 ;
     163FIND ; -- find patient in ^DPT
     164 N X,Y,DIC,ORX,DFN
     165 S DIC=2,DIC(0)="AEQM" D FULL^VALM1
     166 D ^DIC I Y'>0 S VALMBCK="R" Q
     167 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q
     168 S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables
     169 Q
     170 ;
     171SELECT ; -- select patient from list
     172 N NMBR,X,Y,Z,DIC,DFN,ORX S NMBR=+$P(XQORNOD(0),"=",2)
     173 S Y=$G(^TMP("OR",$J,"PATIENTS","IDX",NMBR)),DFN=+Y
     174 I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q
     175 ;W "   "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN
     176 D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q
     177 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q
     178SLCT1 ; -- may enter here with DFN from FIND
     179 N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV
     180 D OERR^VADPT,ELIG^VADPT
     181 S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D
     182 . I $G(NMBR) N X S X=$$CONTEXT^ORQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC  ; use clinic if selected from list, else ask
     183 . S LOC="" ;,X=$$LOCATION^ORCMENU1(1) S:X LOC=X
     184 S ORL=LOC,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)=VAIN(5)
     185 S ORVP=DFN_";DPT(",ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2)
     186 S ORDOB=$P(VADM(3),U,2),ORAGE=VADM(4),ORSEX=$P(VADM(5),U)
     187 S ORTS=+VAIN(3),ORWARD=VAIN(4),ORATTEND=+VAIN(11),ORSC=$G(VAEL(3))
     188 I $P($G(^DGSL(38.1,+ORVP,0)),"^",2),($G(^DPT(+ORVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D
     189 . ; if senstive patient and (patient inpatient or user holds key)
     190 . ; prevents sensitive patient warning from scrolling off screen
     191 . N X
     192 . W !!,"Press <return> to continue ..."
     193 . R X:DTIME
     194SLCT2 ; -- convert patient's orders, if not already done
     195 S ORCNV=$$OTF^OR3CONV(+ORVP) Q:'ORCNV  I ORCNV>0 W !,"DONE" H 1 Q
     196 I ORCNV<0 W $C(7),!!,$P(ORCNV,U,2) H 2 S VALMBCK="R" Q
     197 Q
     198 ;
     199OK(DATE) ; -- Patient is deceased; ok to continue?
     200 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
     201 S DIR("A")="Do you wish to continue? "
     202 W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!"
     203 D ^DIR
     204 Q +Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m

    r613 r623  
    1 ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ; 8/20/07 5:43am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139,243**;Dec 17, 1997;Build 242
    3 VAMCPTS(Y)      ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME
    4         N I,J,V
    5         S I=1
    6         S J=0 F  S J=$O(^DPT("B",J)) Q:J=""  S V=0,V=$O(^DPT("B",J,V))  S Y(I)=V_"^"_J,I=I+1
    7         Q
    8 VAMCLONG(Y,DIR,FROM)    ; return a bolus of patients in VAMC: DFN^NAME
    9         N I,IEN,CNT S CNT=44
    10         I DIR=0 D  ; Forward direction
    11         . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM=""  D
    12         . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
    13         . I +$G(Y(CNT))="" S Y(I)=""
    14         I DIR=1 D  ; Reverse direction
    15         . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM=""  D
    16         . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
    17         Q
    18 DEFTM(ORY)      ; return current user's default team list
    19         Q:'$D(DUZ)
    20         N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
    21         S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B")
    22         Q
    23 TEAMS(ORY)      ; return list of teams for a system
    24         ; Also called under DBIA # 2692.
    25         N ORTM,I,ORTMN
    26         S ORTMN="",I=1
    27         F  S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN=""  D
    28         .S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM=""
    29         .I $P($G(^OR(100.21,ORTM,11)),U)'=0!($D(^OR(100.21,ORTM,1,$G(DUZ,0)))) S ORY(I)=ORTM_U_ORTMN,I=I+1
    30         S:+$G(ORY(1))<1 ORY(1)="^No teams found."
    31         Q
    32 TEAMPTS(ORY,TEAM,TMPFLAG)       ; RETURN LIST OF PATIENTS IN A TEAM
    33         ; Also called under DBIA # 2692.
    34         ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
    35         ;    global root string passed in ORY, and builds the returned
    36         ;    list in that global instead of to a memory array.
    37         N DOTMP,NEWTMP
    38         S DOTMP=0
    39         I $G(TMPFLAG) D             ; Was value passed?
    40         .I TMPFLAG S DOTMP=1        ; Is value TRUE?
    41         I +$G(TEAM)<1 D
    42         .I DOTMP S NEWTMP=ORY_1_")",@NEWTMP="^No team identified" Q
    43         .I 'DOTMP S ORY(1)="^No team identified" Q
    44         N ORI,ORPT,I
    45         S I=0
    46         S ORI=0 F  S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1  D
    47         .S ORPT=^OR(100.21,+TEAM,10,ORI,0)
    48         .I DOTMP D
    49         ..S I=I+1,NEWTMP=ORY_+I_")"
    50         ..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U)
    51         .I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U)
    52         I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found."
    53         I 'DOTMP S:I<1 ORY(1)="^No patients found."
    54         Q
    55 TEAMPR(ORY,PROV)        ; return list of teams linked to a provider
    56         I +$G(PROV)<1 S ORY(1)="^No provider identified" Q
    57         N ORTM,I,ORTMN
    58         S ORTM="",I=1
    59         F  S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1  D
    60         .S ORTMN=$P(^OR(100.21,ORTM,0),U)
    61         .S ORY(I)=ORTM_U_ORTMN,I=I+1
    62         S:+$G(ORY(1))<1 ORY(1)="^No teams found."
    63         Q
    64 TEAMPR2(ORY,PROV)       ; return list of teams linked to a provider
    65         ; This tag added by PKS/slc - 8/1999.
    66         I +$G(PROV)<1 S ORY(1)="^No provider identified" Q
    67         N ORTM,ORDATA,ORTMN,ORTYPE,I
    68         S ORTM="",I=1
    69         F  S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1  D
    70         .S ORDATA=^OR(100.21,ORTM,0) ; Get value.
    71         .S ORTMN=$P(ORDATA,U)        ; Team List name.
    72         .S ORTYPE=$P(ORDATA,U,2)     ; Team List type.
    73         .S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1
    74         S:+$G(ORY(1))<1 ORY(1)="^No teams found."
    75         Q
    76 TEAMPROV(ORY,TEAM)      ; return list of providers linked to a team
    77         I +$G(TEAM)<1 S ORY(1)="^No team identified"
    78         N PROV,I,SEQ
    79         S I=1
    80         S SEQ=0 F  S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1  D
    81         .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D
    82         ..S ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1
    83         S:+$G(ORY(1))<1 ORY(1)="^No providers found."
    84         Q
    85 TPROVPT(PROV)   ;return list of patients linked to a provider via teams
    86         ; Modified by PKS: 8/1999.
    87         I +$G(PROV)<1 S ^TMP("ORLPUPT",$J,"^No provider identified")=""
    88         N ORTM,ORTMN,ORI,ORPT
    89         S ORTM=""
    90         F  S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1  D  ; Teams.
    91         .S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List.
    92         .S ORI=0 F  S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1  D
    93         ..S ORPT=^OR(100.21,+ORTM,10,ORI,0)
    94         ..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))=""
    95         ..; Next line added by PKS:
    96         ..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)=""
    97         I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")=""
    98         Q
    99 TMSPT(ORY,PT)   ;return list of teams linked to a patient (patient is active)
    100         I +$G(PT)<1 S ORY(1)="^No patient identified" Q
    101         N ORTM,I,ORTMN,ORTMTYP
    102         S ORTM="",I=1
    103         F  S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1  D
    104         .S ORTMN=$P(^OR(100.21,ORTM,0),U)
    105         .S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D
    106         ..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"")
    107         .S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1
    108         S:+$G(ORY(1))<1 ORY(1)="^No teams found."
    109         Q
    110 TPTPR(ORY,PT)   ;return list of providers linked to a patient via teams
    111         I +$G(PT)<1 S ORY(1)="^No patient identified" Q
    112         N ORTM,PROV,SEQ
    113         S ORTM=""
    114         F  S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1  D
    115         .S SEQ=0 F  S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1  D
    116         ..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D
    117         ...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U)
    118         S:'$D(ORY) ORY(1)="^No providers found."
    119         Q
    120 PERSPR(ORY)     ; return list of personal lists linked to current user
    121         N ORTM,I,ORTMN
    122         S ORTM="",I=1
    123         F  S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1  D
    124         .Q:$P(^OR(100.21,ORTM,0),U,2)'="P"  ;quit if not a personal list
    125         .S ORTMN=$P(^OR(100.21,ORTM,0),U)
    126         .S ORY(I)=ORTM_U_ORTMN,I=I+1
    127         S:+$G(ORY(1))<1 ORY(1)="^No personal lists found."
    128         Q
    129 PRIMPT(ORY,ORPT)        ; return patient's PCMM primary care team
    130         I +$G(ORPT)<1 S ORY(1)="^No patient identified"
    131         N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX
    132         S ORQPUR(2)=""  ;"2" is the ien for purpose "primary care" [^SD(403.47]
    133         D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0
    134         S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR")
    135         I ORQERROR=0 S ORY="^Error in search for primary care team."
    136         I +$G(ORQLST(1))>0 D
    137         .S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5)
    138         .I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2)
    139         S:+$G(ORY)<1 ORY="^No primary care team found."
    140         K %
    141         Q
    142 PROVPT(ORY,ORPT)        ; return PCMM primary provider for a patient
    143         I +$G(ORPT)<1 S ORY(1)="^No patient identified"
    144         S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1)
    145         Q
    146 PPLINK(ORPROV,ORPT)     ; returns '1' if patient is linked to provider
    147         N ORX,ORPP
    148         S ORX="",ORPP=0
    149         I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0
    150         I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM"  ;provider is patient's primary
    151         I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD"  ;provider is patient's attending
    152         ;is provider and patient on the same team:
    153         D TPROVPT(ORPROV)
    154         F  S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX=""  D
    155         .I +ORX=ORPT S ORPP="1^OERRTM" Q
    156         K ^TMP("ORLPUPT",$J)
    157         ;
    158         ;If not linked already, see if linked via PCMM:
    159         I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT)
    160         ;
    161         Q ORPP
    162 PDLINK(ORDEV,ORPT)      ; returns '1' if patient is linked to device via team
    163         ;ORDEV can be either ien or device name
    164         N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN
    165         S ORDP=0
    166         I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0
    167         ; Are device and patient on the same team?:
    168         I '$D(^%ZIS(1,ORDEV,0)) D  ;ORDEV is not an ien
    169         .S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN))
    170         .S ORDEV=ORDEVIEN
    171         Q:+$G(ORDEV)<1 0
    172         D TMSPT(.ORY,ORPT)
    173         S ORX="" F  S ORX=$O(ORY(ORX)) Q:ORX=""  D
    174         .S ORTM=ORY(ORX)
    175         .I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q
    176         Q ORDP
    177 PCMMLINK(ORPROV,ORPT)   ;returns '1' if patient is linked to provider via PCMM
    178         N ORPP,ORPCMM,ORPCP
    179         S ORPP=0
    180         I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0
    181         ;
    182         ;provider is patient's PCMM primary care practitioner:
    183         I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP"   ;DBIA #1252
    184         ;
    185         ;provider is patient's PCMM associate provider:
    186         I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP"      ;DBIA #1252
    187         ;
    188         ;provider is linked to patient via PCMM team position assignment:
    189         S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",)  ;DBIA #1916
    190         S ORPCP=0
    191         F  S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1  D
    192         .I ORPROV=ORPCP S ORPP="1^PCMMTM"
    193         K ^TMP("ORPCMMLK",$J)
    194         ;
    195         Q ORPP
    196 PUNSIGN(ORY,ORBDFN)     ;rtns array of providers with unsigned orders for pt
    197         N ORDG,ORX,ORZ,ORDNUM
    198         S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
    199         K ^TMP("ORR",$J)
    200         ;get unsigned orders:
    201         D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0)
    202         S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""
    203         I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D
    204         .S ORX="" F  S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""  D
    205         ..S ORZ="" F  S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1  D
    206         ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
    207         ...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))=""
    208         K ^TMP("ORR",$J)
    209         Q
     1ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ;12/15/97 [ 04/02/97  3:32 PM ] [6/6/01 11:34am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139**;Dec 17, 1997
     3VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME
     4 N I,J,V
     5 S I=1
     6 S J=0 F  S J=$O(^DPT("B",J)) Q:J=""  S V=0,V=$O(^DPT("B",J,V))  S Y(I)=V_"^"_J,I=I+1
     7 Q
     8VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME
     9 N I,IEN,CNT S CNT=44
     10 I DIR=0 D  ; Forward direction
     11 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM=""  D
     12 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
     13 . I +$G(Y(CNT))="" S Y(I)=""
     14 I DIR=1 D  ; Reverse direction
     15 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM=""  D
     16 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
     17 Q
     18DEFTM(ORY) ; return current user's default team list
     19 Q:'$D(DUZ)
     20 N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
     21 S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B")
     22 Q
     23TEAMS(ORY) ; return list of teams for a system
     24 ; Also called under DBIA # 2692.
     25 N ORTM,I,ORTMN
     26 S ORTMN="",I=1
     27 F  S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN=""  D
     28 .S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM=""
     29 .S ORY(I)=ORTM_U_ORTMN,I=I+1
     30 S:+$G(ORY(1))<1 ORY(1)="^No teams found."
     31 Q
     32TEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
     33 ; Also called under DBIA # 2692.
     34 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
     35 ;    global root string passed in ORY, and builds the returned
     36 ;    list in that global instead of to a memory array.
     37 N DOTMP,NEWTMP
     38 S DOTMP=0
     39 I $G(TMPFLAG) D             ; Was value passed?
     40 .I TMPFLAG S DOTMP=1        ; Is value TRUE?
     41 I +$G(TEAM)<1 D
     42 .I DOTMP S NEWTMP=ORY_1_")",@NEWTMP="^No team identified" Q
     43 .I 'DOTMP S ORY(1)="^No team identified" Q
     44 N ORI,ORPT,I
     45 S I=0
     46 S ORI=0 F  S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1  D
     47 .S ORPT=^OR(100.21,+TEAM,10,ORI,0)
     48 .I DOTMP D
     49 ..S I=I+1,NEWTMP=ORY_+I_")"
     50 ..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U)
     51 .I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U)
     52 I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found."
     53 I 'DOTMP S:I<1 ORY(1)="^No patients found."
     54 Q
     55TEAMPR(ORY,PROV) ; return list of teams linked to a provider
     56 I +$G(PROV)<1 S ORY(1)="^No provider identified" Q
     57 N ORTM,I,ORTMN
     58 S ORTM="",I=1
     59 F  S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1  D
     60 .S ORTMN=$P(^OR(100.21,ORTM,0),U)
     61 .S ORY(I)=ORTM_U_ORTMN,I=I+1
     62 S:+$G(ORY(1))<1 ORY(1)="^No teams found."
     63 Q
     64TEAMPR2(ORY,PROV) ; return list of teams linked to a provider
     65 ; This tag added by PKS/slc - 8/1999.
     66 I +$G(PROV)<1 S ORY(1)="^No provider identified" Q
     67 N ORTM,ORDATA,ORTMN,ORTYPE,I
     68 S ORTM="",I=1
     69 F  S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1  D
     70 .S ORDATA=^OR(100.21,ORTM,0) ; Get value.
     71 .S ORTMN=$P(ORDATA,U)        ; Team List name.
     72 .S ORTYPE=$P(ORDATA,U,2)     ; Team List type.
     73 .S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1
     74 S:+$G(ORY(1))<1 ORY(1)="^No teams found."
     75 Q
     76TEAMPROV(ORY,TEAM) ; return list of providers linked to a team
     77 I +$G(TEAM)<1 S ORY(1)="^No team identified"
     78 N PROV,I,SEQ
     79 S I=1
     80 S SEQ=0 F  S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1  D
     81 .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D
     82 ..S ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1
     83 S:+$G(ORY(1))<1 ORY(1)="^No providers found."
     84 Q
     85TPROVPT(PROV) ;return list of patients linked to a provider via teams
     86 ; Modified by PKS: 8/1999.
     87 I +$G(PROV)<1 S ^TMP("ORLPUPT",$J,"^No provider identified")=""
     88 N ORTM,ORTMN,ORI,ORPT
     89 S ORTM=""
     90 F  S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1  D  ; Teams.
     91 .S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List.
     92 .S ORI=0 F  S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1  D
     93 ..S ORPT=^OR(100.21,+ORTM,10,ORI,0)
     94 ..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))=""
     95 ..; Next line added by PKS:
     96 ..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)=""
     97 I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")=""
     98 Q
     99TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active)
     100 I +$G(PT)<1 S ORY(1)="^No patient identified" Q
     101 N ORTM,I,ORTMN,ORTMTYP
     102 S ORTM="",I=1
     103 F  S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1  D
     104 .S ORTMN=$P(^OR(100.21,ORTM,0),U)
     105 .S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D
     106 ..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"")
     107 .S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1
     108 S:+$G(ORY(1))<1 ORY(1)="^No teams found."
     109 Q
     110TPTPR(ORY,PT) ;return list of providers linked to a patient via teams
     111 I +$G(PT)<1 S ORY(1)="^No patient identified" Q
     112 N ORTM,PROV,SEQ
     113 S ORTM=""
     114 F  S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1  D
     115 .S SEQ=0 F  S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1  D
     116 ..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D
     117 ...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U)
     118 S:'$D(ORY) ORY(1)="^No providers found."
     119 Q
     120PERSPR(ORY) ; return list of personal lists linked to current user
     121 N ORTM,I,ORTMN
     122 S ORTM="",I=1
     123 F  S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1  D
     124 .Q:$P(^OR(100.21,ORTM,0),U,2)'="P"  ;quit if not a personal list
     125 .S ORTMN=$P(^OR(100.21,ORTM,0),U)
     126 .S ORY(I)=ORTM_U_ORTMN,I=I+1
     127 S:+$G(ORY(1))<1 ORY(1)="^No personal lists found."
     128 Q
     129PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team
     130 I +$G(ORPT)<1 S ORY(1)="^No patient identified"
     131 N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX
     132 S ORQPUR(2)=""  ;"2" is the ien for purpose "primary care" [^SD(403.47]
     133 D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0
     134 S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR")
     135 I ORQERROR=0 S ORY="^Error in search for primary care team."
     136 I +$G(ORQLST(1))>0 D
     137 .S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5)
     138 .I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2)
     139 S:+$G(ORY)<1 ORY="^No primary care team found."
     140 K %
     141 Q
     142PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient
     143 I +$G(ORPT)<1 S ORY(1)="^No patient identified"
     144 S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1)
     145 Q
     146PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider
     147 N ORX,ORPP
     148 S ORX="",ORPP=0
     149 I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0
     150 I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM"  ;provider is patient's primary
     151 I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD"  ;provider is patient's attending
     152 ;is provider and patient on the same team:
     153 D TPROVPT(ORPROV)
     154 F  S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX=""  D
     155 .I +ORX=ORPT S ORPP="1^OERRTM" Q
     156 K ^TMP("ORLPUPT",$J)
     157 ;
     158 ;If not linked already, see if linked via PCMM:
     159 I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT)
     160 ;
     161 Q ORPP
     162PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team
     163 ;ORDEV can be either ien or device name
     164 N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN
     165 S ORDP=0
     166 I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0
     167 ; Are device and patient on the same team?:
     168 I '$D(^%ZIS(1,ORDEV,0)) D  ;ORDEV is not an ien
     169 .S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN))
     170 .S ORDEV=ORDEVIEN
     171 Q:+$G(ORDEV)<1 0
     172 D TMSPT(.ORY,ORPT)
     173 S ORX="" F  S ORX=$O(ORY(ORX)) Q:ORX=""  D
     174 .S ORTM=ORY(ORX)
     175 .I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q
     176 Q ORDP
     177PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM
     178 N ORPP,ORPCMM,ORPCP
     179 S ORPP=0
     180 I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0
     181 ;
     182 ;provider is patient's PCMM primary care practitioner:
     183 I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP"   ;DBIA #1252
     184 ;
     185 ;provider is patient's PCMM associate provider:
     186 I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP"      ;DBIA #1252
     187 ;
     188 ;provider is linked to patient via PCMM team position assignment:
     189 S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",)  ;DBIA #1916
     190 S ORPCP=0
     191 F  S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1  D
     192 .I ORPROV=ORPCP S ORPP="1^PCMMTM"
     193 K ^TMP("ORPCMMLK",$J)
     194 ;
     195 Q ORPP
     196PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt
     197 N ORDG,ORX,ORZ,ORDNUM
     198 S ORDG=$$DG^ORQOR1("ALL")  ;get Display Group ien
     199 K ^TMP("ORR",$J)
     200 ;get unsigned orders:
     201 D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0)
     202 S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""
     203 I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D
     204 .S ORX="" F  S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""  D
     205 ..S ORZ="" F  S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1  D
     206 ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
     207 ...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))=""
     208 K ^TMP("ORR",$J)
     209 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQAL.m

    r613 r623  
    1 ORQQAL  ; slc/CLA,JFR - Functions which return patient allergy data ;6/8/06  14:11
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,85,162,190,216,232,243**;Dec 17, 1997;Build 242
    3 LIST(ORAY,ORPT) ; RETURN PATIENT'S ALLERGY/ADVERSE REACTION INFO:
    4         ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies
    5         ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien
    6         N I,J,K
    7         S I=1,J=0,K=0
    8         D EN1^GMRAOR1(ORPT,"GMRARXN")
    9         I $G(GMRARXN)="" S ORAY(I)="^No Allergy Assessment"
    10         I $G(GMRARXN)=0 S ORAY(I)="^No Known Allergies"
    11         I $G(GMRARXN)=1 F  S J=$O(GMRARXN(J)) Q:J=""  S ORAY(I)=$P(GMRARXN(J),"^",3)_"^"_$P(GMRARXN(J),"^")_"^"_$P(GMRARXN(J),"^",2) D SIGNS S I=I+1
    12         S:'$D(ORAY(1)) ORAY(1)="^No allergies found."
    13         K GMRARXN
    14         Q
    15 SIGNS   S K=0,N=0 F  S K=$O(GMRARXN(J,"S",K)) Q:K'>0  D
    16         .I N=0 S ORAY(I)=ORAY(I)_"^"_$P(GMRARXN(J,"S",K),";")
    17         .E  S ORAY(I)=ORAY(I)_";"_$P(GMRARXN(J,"S",K),";")
    18         .S N=N+1
    19         Q
    20 LRPT(ORAY,ORPT) ; RETURN PT'S ALLERGY/ADVERSE REACTION INFO IN REPORT FORMAT:
    21         ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies
    22         ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien
    23         N I,J,K,SEVER,CR,GMRAIDT ;216
    24         S CR=$CHAR(13)
    25         S I=1,J=0,K=0,SEVER="",GMRAIDT=1 ;216
    26         D EN1^GMRAOR1(ORPT,"GMRARXN")
    27         I $G(GMRARXN)="" S ORAY(I)="No Allergy Assessment"
    28         I $G(GMRARXN)=0 S ORAY(I)="No Known Allergies"
    29         I $G(GMRARXN)=1 F  S J=$O(GMRARXN(J)) Q:J=""  D
    30         .S SEVER=$P(GMRARXN(J),U,2)
    31         .S ORAY(I)=$P(GMRARXN(J),U)_"     "_$S($L($G(SEVER)):"[Severity: "_SEVER_"]",1:""),I=I+1
    32         .S K=0,N=0 F  S K=$O(GMRARXN(J,"S",K)) Q:K'>0  D
    33         ..I N=0 S ORAY(I)="    Signs/symptoms: "_$P(GMRARXN(J,"S",K),";")
    34         ..E     S ORAY(I)="                    "_$P(GMRARXN(J,"S",K),";")
    35         ..I $P(GMRARXN(J,"S",K),";",2) S ORAY(I)=ORAY(I)_" ("_$$FMTE^XLFDT($P(GMRARXN(J,"S",K),";",2),2)_")" ;216
    36         ..S N=N+1,I=I+1
    37         .S ORAY(I)=" ",I=I+1
    38         S:'$D(ORAY(1)) ORAY(1)="No allergies found."
    39         K GMRARXN
    40         Q
    41 RXN(ORAY,ORPT,SRC,NDF,PSDRUG)   ; RETURN TRUE OR FALSE IF PATIENT IS ALLERGIC TO AGENT
    42         ; SRC: ALLERGEN SOURCE (CM=CONTRAST MEDIA, DR=DRUG)
    43         ; NDF: IF SRC=DR, NDF=Nat'l Drug File ien ELSE NDF=""
    44         ; PSDRUG:IF SRC=DR, PSDRUG=(local) Drug file ien ELSE PSDRUG=""
    45         S ORAY=$$ORCHK^GMRAOR(ORPT,SRC,NDF)
    46         I SRC="DR",ORAY=1 D  ;drug ingredient allergy found
    47         .S I=1,J=0 F  S J=$O(GMRAING(J)) Q:J=""  D
    48         ..I I=1 S ORAY=ORAY_U_GMRAING(J)
    49         ..E  S ORAY=ORAY_";"_GMRAING(J)
    50         ..S I=I+1
    51         I SRC="DR",ORAY=2 D  ;drug class allergy found
    52         .S CL="",I=1,J=0 F  S J=$O(GMRADRCL(J)) Q:J=""  D
    53         ..; per test sites 3/17/04 - no oc for pt allergy to entire HERBS class:
    54         ..Q:$P(GMRADRCL(J),U)="HA000"
    55         ..I I=1 S ORAY=ORAY_U_$P(GMRADRCL(J),U,2)
    56         ..E  S CL=$P(GMRADRCL(J),U,2) I ORAY'[CL S ORAY=ORAY_";"_CL
    57         ..S I=I+1
    58         I SRC="DR",(+$G(ORAY)<1) D MEDCLASS(.ORAY,ORPT,PSDRUG)
    59         K I,J,GMRADRCL,GMRAING,CL
    60         Q
    61 MEDCLASS(ORAY,DFN,PSDRUG)       ;check for allergens with medications in same VA drug class
    62         N ORVACLS,CL,X,I,RET,TYP
    63         S TYP="DR"
    64         Q:+$G(PSDRUG)<1
    65         ;S ORVACLS=$P(^PSDRUG(PSDRUG,0),U,2)
    66         S ORVACLS=$$CLASS50^ORPEAPI(PSDRUG)
    67         Q:$L(ORVACLS)<4
    68         Q:$G(ORVACLS)="HA000"  ;don't process herbal drug class for order checks
    69         S CL=$S($E(ORVACLS,1,4)="CN10":5,1:4) ;look at 5 chars if ANALGESICS
    70         D GETDATA^GMRAOR(DFN)
    71         Q:'$D(^TMP("GMRAOC",$J,"APC"))
    72         S I="" F  S I=$O(^TMP("GMRAOC",$J,"APC",I)) Q:'$L(I)  D
    73         .I $E(I,1,CL)=$E(ORVACLS,1,CL) S X=I
    74         I $L($G(X)) D
    75         .N IEN,NAME
    76         .D IEN^PSN50P65(,X,"ORQQAL")
    77         .S IEN=$O(^TMP($J,"ORQQAL","B",X,0))
    78         .I 'IEN S ORAY="2"_U_X Q
    79         .S NAME=$G(^TMP($J,"ORQQAL",IEN,1))
    80         .I '$L(NAME) S ORAY="2"_U_X Q
    81         .S ORAY="2"_U_NAME_": ("_$G(^TMP("GMRAOC",$J,"APC",X))_")"
    82         K ^TMP("GMRAOC",$J)
    83         Q
    84 DETAIL(ORAY,DFN,ALLR,ID)        ; RETURN DETAILED ALLERGY INFO FOR SPECIFIED ALLERGIC REACTION:
    85         D EN1^GMRAOR2(ALLR,"GMRACT")
    86         N CR,OX,OH S CR=$CHAR(13),I=1
    87         S ORAY(I)="    Causative agent: "_$P(GMRACT,U),I=I+1
    88         S ORAY(I)=" Nature of Reaction: "_$S($P(GMRACT,U,6)="ALLERGY":"Allergy",$P(GMRACT,U,6)="PHARMACOLOGIC":"Adverse Reaction",$P(GMRACT,U,6)="UNKNOWN":"Unknown",1:""),I=I+1 ;216
    89         S ORAY(I)=" ",I=I+1
    90         I $D(GMRACT("S",1)) D SYMP
    91         I $D(GMRACT("V",1)) D CLAS
    92         S ORAY(I)="         Originator: "_$P(GMRACT,U,2)_$S($L($P(GMRACT,U,3)):" ("_$P(GMRACT,U,3)_")",1:""),I=I+1 ;216
    93         S ORAY(I)="         Originated: "_$P(GMRACT,U,10),I=I+1 ;216
    94         I $D(GMRACT("O",1)) D OBS
    95         S ORAY(I)="           Verified: "_$S($P(GMRACT,U,4)="VERIFIED":$P(GMRACT,U,8),1:"No"),I=I+1 ;216
    96         S ORAY(I)="Observed/Historical: "_$S($P(GMRACT,U,5)="OBSERVED":"Observed",$P(GMRACT,U,5)="HISTORICAL":"Historical",1:""),I=I+1
    97         I $D(GMRACT("C",1)) D COM
    98         K GMRACT
    99         Q
    100 SYMP    S K=0,N=0 F  S K=$O(GMRACT("S",K)) Q:K'>0  D
    101         .I N=0 S ORAY(I)="     Signs/symptoms: "_GMRACT("S",K),I=I+1
    102         .E  S ORAY(I)="                     "_GMRACT("S",K),I=I+1
    103         .S N=N+1
    104         S ORAY(I)=" ",I=I+1
    105         K N,K
    106         Q
    107 CLAS    S K=0,N=0 F  S K=$O(GMRACT("V",K)) Q:K'>0  D
    108         .I N=0 S ORAY(I)="       Drug Classes: "_$P(GMRACT("V",K),U,2),I=I+1
    109         .E  S ORAY(I)="                     "_$P(GMRACT("V",K),U,2),I=I+1
    110         .S N=N+1
    111         S ORAY(I)=" ",I=I+1
    112         K N,K
    113         Q
    114 OBS     S K=0,N=0 F  S K=$O(GMRACT("O",K)) Q:K'>0  D
    115         .I N=0 D
    116         ..S Y=$P(GMRACT("O",K),U) D DD^%DT
    117         ..S ORAY(I)=" Obs dates/severity: "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1
    118         .E  D
    119         ..S Y=$P(GMRACT("O",K),U) D DD^%DT
    120         ..S ORAY(I)="                     "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1
    121         .S N=N+1
    122         S ORAY(I)=" ",I=I+1
    123         K N,K,Y
    124         Q
    125 COM     S K=0,N=0,ORAY(I)=" ",I=I+1
    126         F  S K=$O(GMRACT("C",K)) Q:K'>0  D
    127         .I N=0 S ORAY(I)="Comments:",I=I+1
    128         .S Y=$P(GMRACT("C",K),U) D DD^%DT
    129         .S ORAY(I)="   "_Y_" by "_$P(GMRACT("C",K),U,2),I=I+1
    130         .I $D(GMRACT("C",K,1,0)) S L=0 F  S L=$O(GMRACT("C",K,L)) Q:L'>0  D
    131         ..S ORAY(I)=GMRACT("C",K,L,0),I=I+1
    132         .S N=N+1
    133         S ORAY(I)=" ",I=I+1
    134         K N,K,L,Y
    135         Q
     1ORQQAL ; slc/CLA,JFR - Functions which return patient allergy data ;6/8/06  14:11
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,85,162,190,216,232**;Dec 17, 1997;Build 19
     3LIST(ORAY,ORPT) ; RETURN PATIENT'S ALLERGY/ADVERSE REACTION INFO:
     4 ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies
     5 ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien
     6 N I,J,K
     7 S I=1,J=0,K=0
     8 D EN1^GMRAOR1(ORPT,"GMRARXN")
     9 I $G(GMRARXN)="" S ORAY(I)="^No Allergy Assessment"
     10 I $G(GMRARXN)=0 S ORAY(I)="^No Known Allergies"
     11 I $G(GMRARXN)=1 F  S J=$O(GMRARXN(J)) Q:J=""  S ORAY(I)=$P(GMRARXN(J),"^",3)_"^"_$P(GMRARXN(J),"^")_"^"_$P(GMRARXN(J),"^",2) D SIGNS S I=I+1
     12 S:'$D(ORAY(1)) ORAY(1)="^No allergies found."
     13 K GMRARXN
     14 Q
     15SIGNS S K=0,N=0 F  S K=$O(GMRARXN(J,"S",K)) Q:K'>0  D
     16 .I N=0 S ORAY(I)=ORAY(I)_"^"_$P(GMRARXN(J,"S",K),";")
     17 .E  S ORAY(I)=ORAY(I)_";"_$P(GMRARXN(J,"S",K),";")
     18 .S N=N+1
     19 Q
     20LRPT(ORAY,ORPT) ; RETURN PT'S ALLERGY/ADVERSE REACTION INFO IN REPORT FORMAT:
     21 ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies
     22 ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien
     23 N I,J,K,SEVER,CR,GMRAIDT ;216
     24 S CR=$CHAR(13)
     25 S I=1,J=0,K=0,SEVER="",GMRAIDT=1 ;216
     26 D EN1^GMRAOR1(ORPT,"GMRARXN")
     27 I $G(GMRARXN)="" S ORAY(I)="No Allergy Assessment"
     28 I $G(GMRARXN)=0 S ORAY(I)="No Known Allergies"
     29 I $G(GMRARXN)=1 F  S J=$O(GMRARXN(J)) Q:J=""  D
     30 .S SEVER=$P(GMRARXN(J),U,2)
     31 .S ORAY(I)=$P(GMRARXN(J),U)_"     "_$S($L($G(SEVER)):"[Severity: "_SEVER_"]",1:""),I=I+1
     32 .S K=0,N=0 F  S K=$O(GMRARXN(J,"S",K)) Q:K'>0  D
     33 ..I N=0 S ORAY(I)="    Signs/symptoms: "_$P(GMRARXN(J,"S",K),";")
     34 ..E     S ORAY(I)="                    "_$P(GMRARXN(J,"S",K),";")
     35 ..I $P(GMRARXN(J,"S",K),";",2) S ORAY(I)=ORAY(I)_" ("_$$FMTE^XLFDT($P(GMRARXN(J,"S",K),";",2),2)_")" ;216
     36 ..S N=N+1,I=I+1
     37 .S ORAY(I)=" ",I=I+1
     38 S:'$D(ORAY(1)) ORAY(1)="No allergies found."
     39 K GMRARXN
     40 Q
     41RXN(ORAY,ORPT,SRC,NDF,PSDRUG) ; RETURN TRUE OR FALSE IF PATIENT IS ALLERGIC TO AGENT
     42 ; SRC: ALLERGEN SOURCE (CM=CONTRAST MEDIA, DR=DRUG)
     43 ; NDF: IF SRC=DR, NDF=Nat'l Drug File ien ELSE NDF=""
     44 ; PSDRUG:IF SRC=DR, PSDRUG=(local) Drug file ien ELSE PSDRUG=""
     45 S ORAY=$$ORCHK^GMRAOR(ORPT,SRC,NDF)
     46 I SRC="DR",ORAY=1 D  ;drug ingredient allergy found
     47 .S I=1,J=0 F  S J=$O(GMRAING(J)) Q:J=""  D
     48 ..I I=1 S ORAY=ORAY_U_GMRAING(J)
     49 ..E  S ORAY=ORAY_";"_GMRAING(J)
     50 ..S I=I+1
     51 I SRC="DR",ORAY=2 D  ;drug class allergy found
     52 .S CL="",I=1,J=0 F  S J=$O(GMRADRCL(J)) Q:J=""  D
     53 ..; per test sites 3/17/04 - no oc for pt allergy to entire HERBS class:
     54 ..Q:$P(GMRADRCL(J),U)="HA000"
     55 ..I I=1 S ORAY=ORAY_U_$P(GMRADRCL(J),U,2)
     56 ..E  S CL=$P(GMRADRCL(J),U,2) I ORAY'[CL S ORAY=ORAY_";"_CL
     57 ..S I=I+1
     58 I SRC="DR",(+$G(ORAY)<1) D MEDCLASS(.ORAY,ORPT,PSDRUG)
     59 K I,J,GMRADRCL,GMRAING,CL
     60 Q
     61MEDCLASS(ORAY,DFN,PSDRUG) ;check for allergens with medications in same VA drug class
     62 N ORVACLS,CL,X,I,RET,TYP
     63 S TYP="DR"
     64 Q:+$G(PSDRUG)<1
     65 S ORVACLS=$P(^PSDRUG(PSDRUG,0),U,2)
     66 Q:$L(ORVACLS)<4
     67 Q:$G(ORVACLS)="HA000"  ;don't process herbal drug class for order checks
     68 S CL=$S($E(ORVACLS,1,4)="CN10":5,1:4) ;look at 5 chars if ANALGESICS
     69 D GETDATA^GMRAOR(DFN)
     70 Q:'$D(^TMP("GMRAOC",$J,"APC"))
     71 S I="" F  S I=$O(^TMP("GMRAOC",$J,"APC",I)) Q:'$L(I)  D
     72 .I $E(I,1,CL)=$E(ORVACLS,1,CL) S X=I
     73 I $L($G(X)) D
     74 .N IEN,NAME
     75 .D IEN^PSN50P65(,X,"ORQQAL")
     76 .S IEN=$O(^TMP($J,"ORQQAL","B",X,0))
     77 .I 'IEN S ORAY="2"_U_X Q
     78 .S NAME=$G(^TMP($J,"ORQQAL",IEN,1))
     79 .I '$L(NAME) S ORAY="2"_U_X Q
     80 .S ORAY="2"_U_NAME_": ("_$G(^TMP("GMRAOC",$J,"APC",X))_")"
     81 K ^TMP("GMRAOC",$J)
     82 Q
     83DETAIL(ORAY,DFN,ALLR,ID) ; RETURN DETAILED ALLERGY INFO FOR SPECIFIED ALLERGIC REACTION:
     84 D EN1^GMRAOR2(ALLR,"GMRACT")
     85 N CR,OX,OH S CR=$CHAR(13),I=1
     86 S ORAY(I)="    Causative agent: "_$P(GMRACT,U),I=I+1
     87 S ORAY(I)=" Nature of Reaction: "_$S($P(GMRACT,U,6)="ALLERGY":"Allergy",$P(GMRACT,U,6)="PHARMACOLOGIC":"Adverse Reaction",$P(GMRACT,U,6)="UNKNOWN":"Unknown",1:""),I=I+1 ;216
     88 S ORAY(I)=" ",I=I+1
     89 I $D(GMRACT("S",1)) D SYMP
     90 I $D(GMRACT("V",1)) D CLAS
     91 S ORAY(I)="         Originator: "_$P(GMRACT,U,2)_$S($L($P(GMRACT,U,3)):" ("_$P(GMRACT,U,3)_")",1:""),I=I+1 ;216
     92 S ORAY(I)="         Originated: "_$P(GMRACT,U,10),I=I+1 ;216
     93 I $D(GMRACT("O",1)) D OBS
     94 S ORAY(I)="           Verified: "_$S($P(GMRACT,U,4)="VERIFIED":$P(GMRACT,U,8),1:"No"),I=I+1 ;216
     95 S ORAY(I)="Observed/Historical: "_$S($P(GMRACT,U,5)="OBSERVED":"Observed",$P(GMRACT,U,5)="HISTORICAL":"Historical",1:""),I=I+1
     96 I $D(GMRACT("C",1)) D COM
     97 K GMRACT
     98 Q
     99SYMP S K=0,N=0 F  S K=$O(GMRACT("S",K)) Q:K'>0  D
     100 .I N=0 S ORAY(I)="     Signs/symptoms: "_GMRACT("S",K),I=I+1
     101 .E  S ORAY(I)="                     "_GMRACT("S",K),I=I+1
     102 .S N=N+1
     103 S ORAY(I)=" ",I=I+1
     104 K N,K
     105 Q
     106CLAS S K=0,N=0 F  S K=$O(GMRACT("V",K)) Q:K'>0  D
     107 .I N=0 S ORAY(I)="       Drug Classes: "_$P(GMRACT("V",K),U,2),I=I+1
     108 .E  S ORAY(I)="                     "_$P(GMRACT("V",K),U,2),I=I+1
     109 .S N=N+1
     110 S ORAY(I)=" ",I=I+1
     111 K N,K
     112 Q
     113OBS S K=0,N=0 F  S K=$O(GMRACT("O",K)) Q:K'>0  D
     114 .I N=0 D
     115 ..S Y=$P(GMRACT("O",K),U) D DD^%DT
     116 ..S ORAY(I)=" Obs dates/severity: "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1
     117 .E  D
     118 ..S Y=$P(GMRACT("O",K),U) D DD^%DT
     119 ..S ORAY(I)="                     "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1
     120 .S N=N+1
     121 S ORAY(I)=" ",I=I+1
     122 K N,K,Y
     123 Q
     124COM S K=0,N=0,ORAY(I)=" ",I=I+1
     125 F  S K=$O(GMRACT("C",K)) Q:K'>0  D
     126 .I N=0 S ORAY(I)="Comments:",I=I+1
     127 .S Y=$P(GMRACT("C",K),U) D DD^%DT
     128 .S ORAY(I)="   "_Y_" by "_$P(GMRACT("C",K),U,2),I=I+1
     129 .I $D(GMRACT("C",K,1,0)) S L=0 F  S L=$O(GMRACT("C",K,L)) Q:L'>0  D
     130 ..S ORAY(I)=GMRACT("C",K,L,0),I=I+1
     131 .S N=N+1
     132 S ORAY(I)=" ",I=I+1
     133 K N,K,L,Y
     134 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m

    r613 r623  
    1 ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ; 02/12/08
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243**;Dec 17, 1997;Build 242
    3         ;
    4         ;------------------------- GET PROBLEM FROM LEXICON -------------------
    5         ;
    6 LEXSRCH(LIST,FROM,N,VIEW,ORDATE)        ; Get candidate Problems from LEX file
    7         N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME
    8         S:'+$G(ORDATE) ORDATE=DT
    9         S:'$G(N) N=100
    10         S:'$L($G(VIEW)) VIEW="PL1"
    11         D CONFIG^LEXSET("GMPL",VIEW,ORDATE)
    12         D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
    13         S S=0
    14         F  S S=$O(LEX("LIST",S)) Q:S<1  D
    15         . S VAL1=LEX("LIST",S)
    16         . S COD="",CIEN="",SYS="",NAME=""
    17         . I $L(VAL1,"CPT-4 ")>1 D
    18         .. S SYS="ICD-9-CM "
    19         .. S COD="799.9"
    20         .. S CIEN=""
    21         .. S NAME=$P(VAL1," (CPT-4")
    22         . I $L(VAL1,"DSM-IV ")>1 D
    23         .. S SYS="DSM-IV "
    24         .. S COD=$P($P(VAL1,SYS,2),")")
    25         .. S:COD["/" COD=$P(COD,"/",1)
    26         .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
    27         .. S NAME=$P(VAL1," (DSM-IV")
    28         .. ;
    29         . I $L(VAL1,"(TITLE 38 ")>1 D
    30         .. S SYS="TITLE 38 "
    31         .. S COD=$P($P(VAL1,SYS,2),")")
    32         .. S:COD["/" COD=$P(COD,"/",1)
    33         .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
    34         .. S NAME=$P(VAL1,"(TITLE 38 ")
    35         .. ;
    36         . I $L(VAL1,"ICD-9-CM ")>1 D
    37         .. S SYS="ICD-9-CM "
    38         .. S COD=$P($P(VAL1,SYS,2),")")
    39         .. S:COD["/" COD=$P(COD,"/",1)
    40         .. S CIEN=+$$CODEN^ICDCODE(COD,80)
    41         .. S NAME=$P(VAL1," (ICD-9-CM")
    42         . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *")
    43         . ;
    44         . ; jeh Clean left over codes
    45         . S NAME=$P(NAME," (CPT-4")
    46         . S NAME=$P(NAME," (DSM-IV")
    47         . S NAME=$P(NAME,"(TITLE 38 ")
    48         . S NAME=$P(NAME," (ICD-9-CM")
    49         . ;
    50         . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system
    51         . S LIST(S)=VAL
    52         . S MAX=S
    53         I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT"))
    54         K ^TMP("LEXSCH",$J)
    55         Q
    56         ;
    57 ICDREC(COD)     ;
    58         N CODIEN
    59         I COD="" Q ""
    60         S COD=$P($P(COD,U),"/")
    61         S CODIEN=+$O(^ICD9("AB",COD_" ",0))
    62         S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0))
    63         Q CODIEN
    64         ;Q $O(^ICD9("BA",COD,""))
    65         ;
    66 CPTREC(COD)     ;
    67         I COD="" Q ""
    68         Q $O(^ICPT("BA",COD,""))
    69         ;
    70 EDLOAD(RETURN,DA,GMPROV,GMPVAMC)        ; LOAD  EDIT ARRAYS
    71         ; DA=problem IFN
    72         N I,GMPFLD,GMPORIG,GMPL
    73         D GETFLDS^GMPLEDT3(DA)
    74         S I=0
    75         D LOADFLDS(.RETURN,"GMPFLD","NEW",.I)
    76         D LOADFLDS(.RETURN,"GMPORIG","ORG",.I)
    77         K GMPFLD,GMPORIG,GMPL  ; should not have to do this
    78         Q
    79         ;
    80 LOADFLDS(RETURN,NAM,TYP,I)      ; LOAD FIELDS FOR TYPE OF ARRAY
    81         N S,V,CVP,PN,PID
    82         S S="",V=$C(254)
    83         F  S S=$O(@NAM@(S)) Q:S=10  D
    84         . S RETURN(I)=TYP_V_S_V_@NAM@(S)
    85         . S I=I+1
    86         S S=""
    87         F  S S=$O(@NAM@(10,S)) Q:S=""  D
    88         . S CVP=@NAM@(10,S)
    89         . S PN="" ; provider name
    90         . S PID=$P(CVP,U,6) ; provider id
    91         . I PID'=""  S PN=$$GET1^DIQ(200,PID,.01) ; get provider name
    92         . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN
    93         . S I=I+1
    94         Q
    95         ;
    96 EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES
    97         ; RETURN - boolean, 1 success, 0 failure
    98         ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
    99         ;
    100         N GMPFLD,GMPORIG,S,GMPLUSER
    101         S RETURN=1 ; initialize for success
    102         I UT S GMPLUSER=1
    103         ;
    104         ;S GMPLUSER=1
    105         S S=""
    106         F  S S=$O(EDARRAY(S)) Q:S=""  D
    107         . S @EDARRAY(S)
    108         I $D(GMPFLD(10,"NEW"))>9 D  I 'RETURN Q  ; Bail Out if no lock
    109         . L +^AUPNPROB(GMPIFN,11):10  ; given bogus nature of this lock, should be able to get
    110         . I '$T S RETURN=0
    111         ;
    112         D EN^GMPLSAVE  ; save the data
    113         K GMPFLD,GMPORIG
    114         ;
    115         L -^AUPNPROB(GMPIFN,11)  ; free this instance of lock (in case it was set)
    116         S RETURN=1
    117         Q
    118         ;
    119 UPDATE(ORRETURN,UPDARRAY)       ; UPDATE A PROBLEM RECORD
    120         ; Does essentially same job as EDSAVE above, however does not handle edits to comments
    121         ; or addition of multiple comments.
    122         ; Use initially just for status updates.
    123         ;
    124         N S,GMPL,GMPORIG ; last 2 vars created in nested call
    125         S S=""
    126         F  S S=$O(UPDARRAY(S)) Q:S=""  D
    127         . S @UPDARRAY(S)
    128         D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
    129         K ORARRAY
    130         ; broker wont pick up root node RETURN
    131         S ORRETURN(1)=ORRETURN(0) ; error text
    132         S ORRETURN(0)=ORRETURN ; gmpdfn
    133         I ORRETURN(0)=""  S ORRETURN=1 ; insurance ? need
    134         Q
    135         ;
    136 ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY)  ; SAVE NEW RECORD
    137         ; RETURN - Problem IFN if success, 0 otherwise
    138         ; ADDARRAY - array used for indirect sets of  GMPFLDS()
    139         ;
    140         N DA,GMPFLD,GMPORIG,S
    141         S RETURN=0 ;
    142         L +^AUPNPROB(0):10
    143         Q:'$T  ; bail out if no lock
    144         ;
    145         S S=""
    146         F  S S=$O(ADDARRAY(S)) Q:S=""  D
    147         . S @ADDARRAY(S)
    148         ;
    149         D NEW^GMPLSAVE
    150         ;
    151         S RETURN=DA
    152         ;
    153         L -^AUPNPROB(0)
    154         S RETURN=1
    155         Q
    156         ;
    157 INITUSER(RETURN,ORDUZ)  ; INITIALIZE FOR NEW USER
    158         ; taken from INIT^GMPLMGR
    159         ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE
    160         ;
    161         N X,PV,CTXT,GMPLPROV
    162         S GMPLUSER=$$CLINUSER(DUZ)
    163         S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
    164         S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR
    165         S RETURN(0)=GMPLUSER ;  problem list user, or other user
    166         S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view
    167         S RETURN(2)=+$P(X,U,2) ; verify transcribed problems
    168         S RETURN(3)=+$P(X,U,3) ; prompt for chart copy
    169         S RETURN(4)=+$P(X,U,4) ; use lexicon
    170         S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing
    171         S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A")
    172         S GMPLPROV=$P($G(CTXT),";",5)
    173         I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D
    174         . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U)
    175         E  S RETURN(7)="0^All"
    176         S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section
    177         ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
    178         ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
    179         ;                                 /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
    180         ; Going with this assumption for now:
    181         I $L(RETURN(1),"/")>1 D
    182         . S PV=RETURN(1)
    183         . S RETURN(1)=$P(PV,"/")
    184         . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99)
    185         . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99)
    186         S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc
    187         S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc
    188         S RETURN(11)=""
    189         S RETURN(12)=+$P($G(CTXT),";",4)    ; should comments display?
    190         K GMPLVIEW
    191         Q
    192         ;
    193 CLINUSER(ORDUZ) ;is this a clinical user?
    194         N ORUSER
    195         S ORUSER=0
    196         I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1
    197         I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1
    198         I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1
    199         Q ORUSER
    200         ;
    201 INITPT(RETURN,DFN)      ; GET PATIENT PARAMETERS
    202         Q:+$G(DFN)=0
    203         N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD
    204         ;
    205         S RETURN(0)=DUZ(2) ; facility #
    206         D DEM^VADPT ; get death indicator
    207         S RETURN(1)=$G(VADM(6)) ; death indicator
    208         D VADPT^GMPLX1(DFN) ; get eligibilities
    209         S RETURN(2)=$P(GMPSC,U) ; service connected
    210         S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure
    211         S RETURN(4)=$G(GMPION) ; ionizing radiation exposure
    212         S RETURN(5)=$G(GMPGULF) ; gulf war exposure
    213         S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return
    214         S RETURN(7)=$G(GMPHNC) ; head/neck cancer
    215         S RETURN(8)=$G(GMPMST) ; MST
    216         S RETURN(9)=$G(GMPCV) ; CV
    217         S RETURN(10)=$G(GMPSHD) ; SHAD
    218         Q
    219         ;
    220 PROVSRCH(LST,FLAG,N,FROM,PART)  ; Get candidate Rroviders from person file
    221         N LV,NS,RV,IEN
    222         S RV=$NAME(LV("DILIST","ID"))
    223         IF +$G(N)=0 S N=50
    224         S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART)
    225         D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV")
    226         S NS=""
    227         F  S NS=$O(LV("DILIST",1,NS)) Q:NS=""  D
    228         . S IEN=""
    229         . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ
    230         . S LST(NS)=IEN_U_@RV@(NS,.01)  ; initials_U_@RV@(NS,1)
    231         Q
    232         ;
    233 CLINSRCH(Y,X)   ; Get LIST OF CLINICS
    234         ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of
    235         ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at
    236         ; least on SLC OEX directory.
    237         ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args
    238         N I,NAME,IEN
    239         S I=1,IEN=0,NAME=""
    240         ;access to SC global granted under DBIA #518:
    241         F  S NAME=$O(^SC("B",NAME)) Q:NAME=""  S IEN=$O(^(NAME,0)) D
    242         . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1
    243         Q
    244         ;
    245 SRVCSRCH(Y,FROM,DIR,ALL)        ; GET LIST OF SERVICES
    246         N I,IEN,CNT S I=0,CNT=44
    247         F  Q:I=CNT  S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM=""  D
    248         . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q
    249         . S I=I+1,Y(I)=IEN_"^"_FROM
    250         Q
    251         ;
    252 DUP(Y,DFN,TERM,TEXT)    ;Check for duplicate problem
    253         S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0
    254         I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q
    255         S Y=Y_U_$P(^AUPNPROB(Y,0),U,12)
    256         Q
     1ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ;03/12/02
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249**;Dec 17, 1997
     3 ;
     4 ;------------------------- GET PROBLEM FROM LEXICON -------------------
     5 ;
     6LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file
     7 N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME
     8 S:'+$G(ORDATE) ORDATE=DT
     9 S:'$G(N) N=100
     10 S:'$L($G(VIEW)) VIEW="PL1"
     11 D CONFIG^LEXSET("GMPL",VIEW,ORDATE)
     12 D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
     13 S S=0
     14 F  S S=$O(LEX("LIST",S)) Q:S<1  D
     15 . S VAL1=LEX("LIST",S)
     16 . S COD="",CIEN="",SYS="",NAME=""
     17 . I $L(VAL1,"CPT-4 ")>1 D
     18 .. ;S SYS="CPT-4 "
     19 .. ;S COD=$P($P(VAL1,SYS,2),")")
     20 .. ;S:COD["/" COD=$P(COD,"/",1)
     21 .. ;. S CIEN=$$CODEN^ICPTCOD(COD)
     22 .. S SYS="ICD-9-CM "
     23 .. S COD="799.9"
     24 .. S CIEN=""
     25 .. S NAME=$P(VAL1," (CPT-4")
     26 . I $L(VAL1,"DSM-IV ")>1 D
     27 .. S SYS="DSM-IV "
     28 .. S COD=$P($P(VAL1,SYS,2),")")
     29 .. S:COD["/" COD=$P(COD,"/",1)
     30 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
     31 .. S NAME=$P(VAL1," (DSM-IV")
     32 .. ;
     33 . I $L(VAL1,"(TITLE 38 ")>1 D
     34 .. S SYS="TITLE 38 "
     35 .. S COD=$P($P(VAL1,SYS,2),")")
     36 .. S:COD["/" COD=$P(COD,"/",1)
     37 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
     38 .. S NAME=$P(VAL1,"(TITLE 38 ")
     39 .. ;
     40 . I $L(VAL1,"ICD-9-CM ")>1 D
     41 .. S SYS="ICD-9-CM "
     42 .. S COD=$P($P(VAL1,SYS,2),")")
     43 .. S:COD["/" COD=$P(COD,"/",1)
     44 .. S CIEN=+$$CODEN^ICDCODE(COD,80)
     45 .. S NAME=$P(VAL1," (ICD-9-CM")
     46 . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *")
     47 . ;
     48 . ; jeh Clean left over codes
     49 . S NAME=$P(NAME," (CPT-4")
     50 . S NAME=$P(NAME," (DSM-IV")
     51 . S NAME=$P(NAME,"(TITLE 38 ")
     52 . S NAME=$P(NAME," (ICD-9-CM")
     53 . ;
     54 . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system
     55 . S LIST(S)=VAL
     56 . S MAX=S
     57 I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT"))
     58 Q
     59 ;
     60ICDREC(COD) ;
     61 N CODIEN
     62 I COD="" Q ""
     63 S COD=$P($P(COD,U),"/")
     64 S CODIEN=+$O(^ICD9("AB",COD_" ",0))
     65 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0))
     66 Q CODIEN
     67 ;Q $O(^ICD9("BA",COD,""))
     68 ;
     69CPTREC(COD) ;
     70 I COD="" Q ""
     71 Q $O(^ICPT("BA",COD,""))
     72 ;
     73EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD  EDIT ARRAYS
     74 ; DA=problem IFN
     75 N I,GMPFLD,GMPORIG,GMPL
     76 D GETFLDS^GMPLEDT3(DA)
     77 S I=0
     78 D LOADFLDS(.RETURN,"GMPFLD","NEW",.I)
     79 D LOADFLDS(.RETURN,"GMPORIG","ORG",.I)
     80 K GMPFLD,GMPORIG,GMPL  ; should not have to do this
     81 Q
     82 ;
     83LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY
     84 N S,V,CVP,PN,PID
     85 S S="",V=$C(254)
     86 F  S S=$O(@NAM@(S)) Q:S=10  D
     87 . S RETURN(I)=TYP_V_S_V_@NAM@(S)
     88 . S I=I+1
     89 S S=""
     90 F  S S=$O(@NAM@(10,S)) Q:S=""  D
     91 . S CVP=@NAM@(10,S)
     92 . S PN="" ; provider name
     93 . S PID=$P(CVP,U,6) ; provider id
     94 . I PID'=""  S PN=$$GET1^DIQ(200,PID,.01) ; get provider name
     95 . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN
     96 . S I=I+1
     97 Q
     98 ;
     99EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES
     100 ; RETURN - boolean, 1 success, 0 failure
     101 ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
     102 ;
     103 N GMPFLD,GMPORIG,S,GMPLUSER
     104 S RETURN=1 ; initialize for success
     105 I UT S GMPLUSER=1
     106 ;
     107 ;S GMPLUSER=1
     108 S S=""
     109 F  S S=$O(EDARRAY(S)) Q:S=""  D
     110 . S @EDARRAY(S)
     111 I $D(GMPFLD(10,"NEW"))>9 D  I 'RETURN Q  ; Bail Out if no lock
     112 . L +^AUPNPROB(GMPIFN,11):10  ; given bogus nature of this lock, should be able to get
     113 . I '$T S RETURN=0
     114 ;
     115 D EN^GMPLSAVE  ; save the data
     116 K GMPFLD,GMPORIG
     117 ;
     118 L -^AUPNPROB(GMPIFN,11)  ; free this instance of lock (in case it was set)
     119 S RETURN=1
     120 Q
     121 ;
     122UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD
     123 ; Does essentially same job as EDSAVE above, however does not handle edits to comments
     124 ; or addition of multiple comments.
     125 ; Use initially just for status updates.
     126 ;
     127 N S,GMPL,GMPORIG ; last 2 vars created in nested call
     128 S S=""
     129 F  S S=$O(UPDARRAY(S)) Q:S=""  D
     130 . S @UPDARRAY(S)
     131 D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
     132 K ORARRAY
     133 ; broker wont pick up root node RETURN
     134 S ORRETURN(1)=ORRETURN(0) ; error text
     135 S ORRETURN(0)=ORRETURN ; gmpdfn
     136 I ORRETURN(0)=""  S ORRETURN=1 ; insurance ? need
     137 Q
     138 ;
     139ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD
     140 ; RETURN - Problem IFN if success, 0 otherwise
     141 ; ADDARRAY - array used for indirect sets of  GMPFLDS()
     142 ;
     143 N DA,GMPFLD,GMPORIG,S
     144 S RETURN=0 ;
     145 L +^AUPNPROB(0):10
     146 Q:'$T  ; bail out if no lock
     147 ;
     148 S S=""
     149 F  S S=$O(ADDARRAY(S)) Q:S=""  D
     150 . S @ADDARRAY(S)
     151 ;
     152 D NEW^GMPLSAVE
     153 ;
     154 S RETURN=DA
     155 ;
     156 L -^AUPNPROB(0)
     157 S RETURN=1
     158 Q
     159 ;
     160INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER
     161 ; taken from INIT^GMPLMGR
     162 ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE
     163 ;
     164 N X,PV,CTXT,GMPLPROV
     165 S GMPLUSER=$$CLINUSER(DUZ)
     166 S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
     167 S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR
     168 S RETURN(0)=GMPLUSER ;  problem list user, or other user
     169 S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view
     170 S RETURN(2)=+$P(X,U,2) ; verify transcribed problems
     171 S RETURN(3)=+$P(X,U,3) ; prompt for chart copy
     172 S RETURN(4)=+$P(X,U,4) ; use lexicon
     173 S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing
     174 S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A")
     175 S GMPLPROV=$P($G(CTXT),";",5)
     176 I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D
     177 . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U)
     178 E  S RETURN(7)="0^All"
     179 S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section
     180 ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
     181 ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
     182 ;                                                      /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
     183 ; Going with this assumption for now:
     184 I $L(RETURN(1),"/")>1 D
     185 . S PV=RETURN(1)
     186 . S RETURN(1)=$P(PV,"/")
     187 . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99)
     188 . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99)
     189 S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc
     190 S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc
     191 S RETURN(11)=""
     192 S RETURN(12)=+$P($G(CTXT),";",4)    ; should comments display?
     193 K GMPLVIEW
     194 Q
     195 ;
     196CLINUSER(ORDUZ) ;is this a clinical user?
     197 N ORUSER
     198 S ORUSER=0
     199 I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1
     200 I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1
     201 I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1
     202 Q ORUSER
     203 ;
     204INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS
     205 Q:+$G(DFN)=0
     206 N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST
     207 ;
     208 S RETURN(0)=DUZ(2) ; facility #
     209 D DEM^VADPT ; get death indicator
     210 S RETURN(1)=$G(VADM(6)) ; death indicator
     211 D VADPT^GMPLX1(DFN) ; get eligibilities
     212 S RETURN(2)=$P(GMPSC,U) ; service connected
     213 S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure
     214 S RETURN(4)=$G(GMPION) ; ionizing radiation exposure
     215 S RETURN(5)=$G(GMPGULF) ; gulf war exposure
     216 S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return
     217 S RETURN(7)=$G(GMPHNC) ; head/neck cancer
     218 S RETURN(8)=$G(GMPMST) ; MST
     219 Q
     220 ;
     221PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file
     222 N LV,NS,RV,IEN
     223 S RV=$NAME(LV("DILIST","ID"))
     224 IF +$G(N)=0 S N=50
     225 S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART)
     226 D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV")
     227 S NS=""
     228 F  S NS=$O(LV("DILIST",1,NS)) Q:NS=""  D
     229 . S IEN=""
     230 . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ
     231 . S LST(NS)=IEN_U_@RV@(NS,.01)  ; initials_U_@RV@(NS,1)
     232 Q
     233 ;
     234CLINSRCH(Y,X) ; Get LIST OF CLINICS
     235 ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of
     236 ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at
     237 ; least on SLC OEX directory.
     238 ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args
     239 N I,NAME,IEN
     240 S I=1,IEN=0,NAME=""
     241 ;access to SC global granted under DBIA #518:
     242 F  S NAME=$O(^SC("B",NAME)) Q:NAME=""  S IEN=$O(^(NAME,0)) D
     243 . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1
     244 Q
     245 ;
     246SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES
     247 N I,IEN,CNT S I=0,CNT=44
     248 F  Q:I=CNT  S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM=""  D
     249 . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q
     250 . S I=I+1,Y(I)=IEN_"^"_FROM
     251 Q
     252 ;
     253DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem
     254 S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0
     255 I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q
     256 S Y=Y_U_$P(^AUPNPROB(Y,0),U,12)
     257 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m

    r613 r623  
    1 ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243**;Dec 17, 1997;Build 242
    3         ;
    4         ;---------------- LIST PATIENT PROBLEMS ------------------------
    5         ;
    6 PROBL(ROOT,DFN,CONTEXT)        ;  GET LIST OF PATIENT PROBLEMS
    7         N DIWL,DIWR,DIWF
    8         N ST,ORI,ORX
    9         S (LCNT,NUM)=0
    10         S DIWL=1,DIWR=48,DIWF="C48"
    11         S CONTEXT=";;"_$G(CONTEXT)
    12         I CONTEXT=";;" S CONTEXT=";;A"
    13         S ST=$P(CONTEXT,";",3)
    14         ;
    15         I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only
    16         I ST'="R"  D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here
    17         ;
    18         I ROOT(0)<1 D
    19         . S LCNT=1
    20         . S ROOT(1)="     "_$$PAD^ORCHTAB("No data available.",49)_"|"
    21         Q
    22         ;
    23         ;
    24 LIST(GMPL,GMPDFN,GMPSTAT)             ; -- Returns list of problems for patient GMPDFN
    25         ;    in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
    26         ;                          loc.type^prov^service
    27         ;     & GMPL(0)=number of problems returned
    28         ; This is virtually same as LIST^GMPLUTL2 except that it appends the
    29         ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
    30         ;
    31         N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC
    32         N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT
    33         N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
    34         Q:$G(GMPDFN)'>0
    35         S CNT=0,SP=""
    36         S GMPARAM("QUIET")=1
    37         S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R"
    38         S ORVIEW("ACT")=GMPSTAT
    39         S ORVIEW("PROV")=0
    40         S ORVIEW("VIEW")=""
    41         S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
    42         ;
    43         D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
    44         ;
    45         F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0  D
    46         . S IFN=+ORLIST(NUM) Q:IFN'>0
    47         . S INACT=""
    48         . S GMPL0=$G(^AUPNPROB(IFN,0))
    49         . S GMPL1=$G(^AUPNPROB(IFN,1))
    50         . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
    51         . S CNT=CNT+1
    52         . I +ORICD186 D
    53         . . S ICD=$$CODEC^ICDCODE(+GMPL0)
    54         . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
    55         . E  D
    56         . . S ICD=$P($G(^ICD9(+GMPL0,0)),U)
    57         . S LASTMOD=$P(GMPL0,U,3)
    58         . S ST=$P(GMPL0,U,12)
    59         . S ONSET=$P(GMPL0,U,13)
    60         . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
    61         . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"")
    62         . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"")
    63         . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"")
    64         . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"")
    65         . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"")
    66         . S CV=$S(+$P(GMPL1,U,17):"/CV",1:"")
    67         . S SHD=$S(+$P(GMPL1,U,18):"/SHD",1:"")
    68         . S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
    69         . S LOC=$P(GMPL1,U,8)
    70         . S DTREC=$P(GMPL1,U,9)
    71         . S LT=""
    72         . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1)
    73         . S PROV=$P(GMPL1,U,5) ; responsible provider
    74         . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1)
    75         . S SERV=$P(GMPL1,U,6)
    76         . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI
    77         . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1)
    78         . S SP=""
    79         . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
    80         . S PRIO=$P(GMPL1,U,14)
    81         . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
    82         . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2)
    83         . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
    84         . S GMPL(CNT)=LIN
    85         S GMPL(0)=CNT
    86         Q
    87         ;
    88         ;
    89         ;------------------------------------- GET LIST OF DELETED PROBLEMS -----------------------------
    90         ;
    91 DELLIST(RETURN,GMPDFN)  ; GET LIST OF DELETED PROBLEMS
    92         ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
    93         N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
    94         N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
    95         S I=0,S=""
    96         S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
    97         F  S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S=""  D
    98         . S IFN=""
    99         . F  S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN=""  D
    100         .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D
    101         ... S L0=$G(^AUPNPROB(IFN,0))
    102         ... Q:L0=""
    103         ... S INACT=""
    104         ... S L1=$G(^AUPNPROB(IFN,1))
    105         ... S ST=$P(L0,U,12)
    106         ... S TXT=$$PROBTEXT^GMPLX(IFN)
    107         ... I +ORICD186 D
    108         ... . S ICD=$$CODEC^ICDCODE(+L0)
    109         ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
    110         ... E  D
    111         ... . S ICD=$P($G(^ICD9(+L0,0)),U)
    112         ... S ONSET=$P(L0,U,13)
    113         ... S MOD=$P(L0,U,3)
    114         ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"")
    115         ... S AO=$S(+$P(L1,U,11):"/AO",1:"")
    116         ... S IR=$S(+$P(L1,U,12):"/IR",1:"")
    117         ... S ENV=$S(+$P(L1,U,13):"/EC",1:"")
    118         ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"")
    119         ... S MST=$S(+$P(L1,U,16):"/MST",1:"")
    120         ... S CV=$S(+$P(L1,U,17):"/CV",1:"")
    121         ... S SHD=$S(+$P(L1,U,18):"/SHD",1:"")
    122         ... S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
    123         ... S SP=$$GETSP
    124         ... S LOC=$P(L1,U,8)
    125         ... S LT=""
    126         ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3)
    127         ... S PROV=$P(L1,U,5) ; responsible provider
    128         ... S SERV=$P(L1,U,6)
    129         ... S PRIO=$P(L1,U,14)
    130         ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
    131         ... S DTREC=$P(L1,U,9)
    132         ... S I=I+1
    133         ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
    134         ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2)
    135         ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
    136         ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
    137         S RETURN(0)=I
    138         Q
    139         ;
    140 GETSP() ; GET EXPOSURES
    141         N I
    142         S SP=""
    143         F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
    144         Q SP
    145         ;
    146         ; adapted from ^GMPLBLD3 ;9/96
    147         ;
    148         ; ----------------------- GET USER PROBLEM CATEGORIES --------------
    149         ;
    150 CAT(TMP,ORDUZ,CLIN)     ; Get user category list
    151         N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST
    152         ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
    153         S TG=$NAME(TMP) ; put list in local
    154         K @TG
    155         S (GSEQ,GCNT,LCNT)=0
    156         ;
    157         S GMPLSLST=$$GETUSLST(DUZ,CLIN)  ; get approp list for user
    158         ; Build multiple of category\problems
    159         ; Iterate categories
    160         F  S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0  D
    161         . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
    162         . S ITEM=$G(^GMPL(125.1,IFN,0))
    163         . S GROUP=+$P(ITEM,U,3)
    164         . S HDR=GROUP_U_$P(ITEM,U,4,5)
    165         . S GCNT=GCNT+1
    166         . S @TG@(GCNT)=HDR ; put category into temp global
    167         Q
    168         ;
    169 GETUSLST(ORDUZ,CLIN)    ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER
    170         N GMPLSLST
    171         S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2)
    172         ;I 'GMPLSLST D
    173         I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0))
    174         ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0))  ;$O(^(+CLIN,0))
    175         Q GMPLSLST
    176         ;
    177         ;----------------------- USER PROBLEM LIST --------------------------
    178         ;
    179 PROB(TMP,GROUP) ; Get user problem list for given group
    180         N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186
    181         ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
    182         S TG=$NAME(TMP) ; put list in local
    183         K @TG
    184         S LCNT=0
    185         S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
    186         ;
    187         ; iterate through problems in category
    188         S (PSEQ,PCNT)=0
    189         F  S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0  D
    190         . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0
    191         . S ITEM=$G(^GMPL(125.12,IFN,0))
    192         . S TEXT=$P(ITEM,U,4)
    193         . ; SEE DD for GMPL(125.12,4 :
    194         . ; "...code which is to be displayed... generally assumed to be ICD"
    195         . S CODE=$P(ITEM,U,5)
    196         . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q
    197         . S PCNT=PCNT+1
    198         . ; RETURN:
    199         . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN
    200         . I +ORICD186 D
    201         . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80)
    202         . E  D
    203         . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE)
    204         Q
    205         ;
    206 ICDCODE(COD)       ; RETURN INTERNAL ICD FOR EXTERNAL CODE  (obsolete after CSV patches released - RV)
    207         N CODIEN
    208         I COD="" Q ""
    209         S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0))
    210         S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0))
    211         Q CODIEN
    212         ;
    213         ;------------------ Filter Providers ---------------------
    214         ;
    215 GETRPRV(RETURN,INP)     ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST
    216         ; RETURN - aa list of responsible providers from which to select for filtering
    217         ; INP - array of problem list providers to select from
    218         ;
    219         N S
    220         S S=""
    221         F I=1:1 S S=$O(INP(S)) Q:S=""  D
    222         . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D  Q  ; get next
    223         .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U)
    224         S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider
    225         Q
    226         ;
    227         ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------
    228         ;
    229 GETCLIN(RETURN,INP)     ; Get FILTERED LIST OF CLINICS
    230         ; RETURN NAMES FOR LIST OF CLINICS PASSED IN
    231         N I,S
    232         S S=""
    233         F I=1:1 S S=$O(INP(S)) Q:S=""  D
    234         . I INP(S)'="",$G(^SC(INP(S),0))'="" D  Q  ; get next
    235         .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1)
    236         ;. S RETURN(I)="-1"_U_"None" ; return empty location
    237         Q
    238         ;
    239 GETSRVC(RETURN,INP)     ; GET FILTERED LIST OF INPATIENT SERVICES
    240         ; RETURN NAMES FOR LIST OF IEN PASSED IN
    241         N I,S
    242         S S=""
    243         F I=1:1 S S=$O(INP(S)) Q:S=""  D
    244         . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D  Q  ; get next
    245         .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1)
    246         ;. S RETURN(I)="-1"_U_"None" ; return empty service
    247         Q
     1ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173**;Dec 17, 1997
     3 ;
     4 ;---------------- LIST PATIENT PROBLEMS ------------------------
     5 ;
     6PROBL(ROOT,DFN,CONTEXT)        ;  GET LIST OF PATIENT PROBLEMS
     7 N DIWL,DIWR,DIWF
     8 N ST,ORI,ORX
     9 S (LCNT,NUM)=0
     10 S DIWL=1,DIWR=48,DIWF="C48"
     11 S CONTEXT=";;"_$G(CONTEXT)
     12 I CONTEXT=";;" S CONTEXT=";;A"
     13 S ST=$P(CONTEXT,";",3)
     14 ;
     15 I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only
     16 I ST'="R"  D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here
     17 ;
     18 I ROOT(0)<1 D
     19 . S LCNT=1
     20 . S ROOT(1)="     "_$$PAD^ORCHTAB("No data available.",49)_"|"
     21 Q
     22 ;
     23 ;
     24LIST(GMPL,GMPDFN,GMPSTAT)       ; -- Returns list of problems for patient GMPDFN
     25 ;    in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
     26 ;                          loc.type^prov^service
     27 ;     & GMPL(0)=number of problems returned
     28 ; This is virtually same as LIST^GMPLUTL2 except that it appends the
     29 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
     30 ;
     31 N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC
     32 N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT
     33 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT
     34 Q:$G(GMPDFN)'>0
     35 S CNT=0,SP=""
     36 S GMPARAM("QUIET")=1
     37 S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R"
     38 S ORVIEW("ACT")=GMPSTAT
     39 S ORVIEW("PROV")=0
     40 S ORVIEW("VIEW")=""
     41 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
     42 ;
     43 D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
     44 ;
     45 F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0  D
     46 . S IFN=+ORLIST(NUM) Q:IFN'>0
     47 . S INACT=""
     48 . S GMPL0=$G(^AUPNPROB(IFN,0))
     49 . S GMPL1=$G(^AUPNPROB(IFN,1))
     50 . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
     51 . S CNT=CNT+1
     52 . I +ORICD186 D
     53 . . S ICD=$$CODEC^ICDCODE(+GMPL0)
     54 . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
     55 . E  D
     56 . . S ICD=$P($G(^ICD9(+GMPL0,0)),U)
     57 . S LASTMOD=$P(GMPL0,U,3)
     58 . S ST=$P(GMPL0,U,12)
     59 . S ONSET=$P(GMPL0,U,13)
     60 . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
     61 . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"")
     62 . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"")
     63 . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"")
     64 . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"")
     65 . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"")
     66 . S SCCOND=SC_AO_IR_ENV_HNC_MST
     67 . S LOC=$P(GMPL1,U,8)
     68 . S DTREC=$P(GMPL1,U,9)
     69 . S LT=""
     70 . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1)
     71 . S PROV=$P(GMPL1,U,5) ; responsible provider
     72 . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1)
     73 . S SERV=$P(GMPL1,U,6)
     74 . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI
     75 . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1)
     76 . S SP=""
     77 . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
     78 . S PRIO=$P(GMPL1,U,14)
     79 . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
     80 . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2)
     81 . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
     82 . S GMPL(CNT)=LIN
     83 S GMPL(0)=CNT
     84 Q
     85 ;
     86 ;
     87 ;------------------------------------- GET LIST OF DELETED PROBLEMS -----------------------------
     88 ;
     89DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS
     90 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
     91 N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
     92 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT
     93 S I=0,S=""
     94 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
     95 F  S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S=""  D
     96 . S IFN=""
     97 . F  S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN=""  D
     98 .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D
     99 ... S L0=$G(^AUPNPROB(IFN,0))
     100 ... Q:L0=""
     101 ... S INACT=""
     102 ... S L1=$G(^AUPNPROB(IFN,1))
     103 ... S ST=$P(L0,U,12)
     104 ... S TXT=$$PROBTEXT^GMPLX(IFN)
     105 ... I +ORICD186 D
     106 ... . S ICD=$$CODEC^ICDCODE(+L0)
     107 ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
     108 ... E  D
     109 ... . S ICD=$P($G(^ICD9(+L0,0)),U)
     110 ... S ONSET=$P(L0,U,13)
     111 ... S MOD=$P(L0,U,3)
     112 ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"")
     113 ... S AO=$S(+$P(L1,U,11):"/AO",1:"")
     114 ... S IR=$S(+$P(L1,U,12):"/IR",1:"")
     115 ... S ENV=$S(+$P(L1,U,13):"/EC",1:"")
     116 ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"")
     117 ... S MST=$S(+$P(L1,U,16):"/MST",1:"")
     118 ... S SCCOND=SC_AO_IR_ENV_HNC_MST
     119 ... S SP=$$GETSP
     120 ... S LOC=$P(L1,U,8)
     121 ... S LT=""
     122 ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3)
     123 ... S PROV=$P(L1,U,5) ; responsible provider
     124 ... S SERV=$P(L1,U,6)
     125 ... S PRIO=$P(L1,U,14)
     126 ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
     127 ... S DTREC=$P(L1,U,9)
     128 ... S I=I+1
     129 ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
     130 ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2)
     131 ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
     132 ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
     133 S RETURN(0)=I
     134 Q
     135 ;
     136GETSP() ; GET EXPOSURES
     137 N I
     138 S SP=""
     139 F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
     140 Q SP
     141 ;
     142 ; adapted from ^GMPLBLD3 ;9/96
     143 ;
     144 ; ----------------------- GET USER PROBLEM CATEGORIES --------------
     145 ;
     146CAT(TMP,ORDUZ,CLIN) ; Get user category list
     147 N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST
     148 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
     149 S TG=$NAME(TMP) ; put list in local
     150 K @TG
     151 S (GSEQ,GCNT,LCNT)=0
     152 ;
     153 S GMPLSLST=$$GETUSLST(DUZ,CLIN)  ; get approp list for user
     154 ; Build multiple of category\problems
     155 ; Iterate categories
     156 F  S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0  D
     157 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
     158 . S ITEM=$G(^GMPL(125.1,IFN,0))
     159 . S GROUP=+$P(ITEM,U,3)
     160 . S HDR=GROUP_U_$P(ITEM,U,4,5)
     161 . S GCNT=GCNT+1
     162 . S @TG@(GCNT)=HDR ; put category into temp global
     163 Q
     164 ;
     165GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER
     166 N GMPLSLST
     167 S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2)
     168 ;I 'GMPLSLST D
     169 I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0))
     170 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0))  ;$O(^(+CLIN,0))
     171 Q GMPLSLST
     172 ;
     173 ;----------------------- USER PROBLEM LIST --------------------------
     174 ;
     175PROB(TMP,GROUP) ; Get user problem list for given group
     176 N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186
     177 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
     178 S TG=$NAME(TMP) ; put list in local
     179 K @TG
     180 S LCNT=0
     181 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
     182 ;
     183 ; iterate through problems in category
     184 S (PSEQ,PCNT)=0
     185 F  S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0  D
     186 . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0
     187 . S ITEM=$G(^GMPL(125.12,IFN,0))
     188 . S TEXT=$P(ITEM,U,4)
     189 . ; SEE DD for GMPL(125.12,4 :
     190 . ; "...code which is to be displayed... generally assumed to be ICD"
     191 . S CODE=$P(ITEM,U,5)
     192 . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q
     193 . S PCNT=PCNT+1
     194 . ; RETURN:
     195 . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN
     196 . I +ORICD186 D
     197 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80)
     198 . E  D
     199 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE)
     200 Q
     201 ;
     202ICDCODE(COD)    ; RETURN INTERNAL ICD FOR EXTERNAL CODE  (obsolete after CSV patches released - RV)
     203 N CODIEN
     204 I COD="" Q ""
     205 S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0))
     206 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0))
     207 Q CODIEN
     208 ;
     209 ;------------------ Filter Providers ---------------------
     210 ;
     211GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST
     212 ; RETURN - aa list of responsible providers from which to select for filtering
     213 ; INP - array of problem list providers to select from
     214 ;
     215 N S
     216 S S=""
     217 F I=1:1 S S=$O(INP(S)) Q:S=""  D
     218 . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D  Q  ; get next
     219 .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U)
     220 S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider
     221 Q
     222 ;
     223 ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------
     224 ;
     225GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS
     226 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN
     227 N I,S
     228 S S=""
     229 F I=1:1 S S=$O(INP(S)) Q:S=""  D
     230 . I INP(S)'="",$G(^SC(INP(S),0))'="" D  Q  ; get next
     231 .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1)
     232 ;. S RETURN(I)="-1"_U_"None" ; return empty location
     233 Q
     234 ;
     235GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES
     236 ; RETURN NAMES FOR LIST OF IEN PASSED IN
     237 N I,S
     238 S S=""
     239 F I=1:1 S S=$O(INP(S)) Q:S=""  D
     240 . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D  Q  ; get next
     241 .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1)
     242 ;. S RETURN(I)="-1"_U_"None" ; return empty service
     243 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPXRM.m

    r613 r623  
    1 ORQQPXRM        ; SLC/PJH - Functions for reminder data ;12/04/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,187,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ;ORQQPXRM DIALOG ACTIVE
    5 ACTIVE(ORY,ORLIST)      D ACTIVE^PXRMRPCC(.ORY,.ORLIST) Q  ; DBIA 3080
    6         ;
    7         ;ORQQPXRM REMINDER EVALUATION
    8 ALIST(ORY,ORPT,ORLIST)  D ALIST^PXRMRPCA(.ORY,.ORPT,.ORLIST) Q  ; DBIA 3078
    9         ;
    10         ;ORQQPXRM REMINDERS APPLICABLE
    11 APPL(ORY,ORPT,ORLOC)    D EVALCOVR^ORQQPX(.ORY,ORPT,ORLOC) Q
    12         ;D APPL^PXRMRPCA(.ORY,ORPT,ORLOC) Q  ; DBIA 3078
    13         ;
    14         ;ORQQPXRM REMINDER CATEGORIES
    15 CATEGORY(ORY,ORPT,ORLOC)        ;
    16         D CATEGORY^PXRMRPCA(.ORY,ORPT,ORLOC) Q  ; DBIA 3078
    17         ;
    18         ;ORQQPXRM REMINDER DIALOG
    19 DIALOG(ORY,ORREM,DFN)   ;
    20         ; DBIA 3080
    21         N DIEN
    22         D DIALOG^PXRMRPCC(.ORY,ORREM,DFN)
    23         ;I $G(DFN)'="" D DIALOG^PXRMRPCC(.ORY,ORREM,DFN)
    24         ;I $G(DFN)="" D DIALOG^PXRMRPCC(.ORY,ORREM)
    25         I $P($G(ORY(1)),U)=-1 Q
    26         S DIEN=$G(^PXD(811.9,ORREM,51))
    27         S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17)
    28         Q
    29         ;
    30         ;ORQQPXRM EDUCATION SUBTOPICS
    31 EDS(ORY,OREDU)  D EDS^PXRMRPCB(.ORY,OREDU) Q  ; DBIA 3079
    32         ;
    33         ;ORQQPXRM EDUCATION SUMMARY
    34 EDL(ORY,OREM)   D EDL^PXRMRPCB(.ORY,OREM) Q  ; DBIA 3079
    35         ;
    36         ;ORQQPXRM EDUCATION TOPIC
    37 EDU(ORY,OREDU)  D EDU^PXRMRPCB(.ORY,OREDU) Q  ; DBIA 3079
    38         ;
    39         ;ORQQPXRM PROGRESS NOTE HEADER
    40 HDR(ORY,ORLOC)  D HDR^PXRMRPCC(.ORY,ORLOC) Q  ; DBIA 3080
    41         ;
    42         ;ORQQPXRM REMINDERS UNEVALUATED
    43 LIST(ORY,ORPT,ORLOC)    D GETLIST^ORQQPX(.ORY,ORLOC) Q
    44         ;D LIST^PXRMRPCA(.ORY,ORPT,ORLOC) Q  ; DBIA 3078
    45         ;
    46         ;ORQQPXRM MENTAL HEALTH
    47 MH(ORY,OTEST)   ;
    48         D MH^PXRMRPCC(.ORY,OTEST)  ; DBIA 3080
    49         S ORY(0)=0
    50         I $$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=1
    51         Q
    52         ;
    53 MHDLL(ORY,DFN,INPUTS)   ;
    54         N CNT,CNT1,ORRESULT,ORSCORES,TEXT
    55         F TEXT="RESULTS","SCORES" D
    56         .S CNT=0,CNT1=0
    57         .F  S CNT=$O(INPUTS(TEXT,CNT)) Q:CNT=""  D
    58         ..S CNT1=CNT1+1
    59         ..I TEXT="RESULTS" S ORRESULT(CNT1)=$G(INPUTS(TEXT,CNT))
    60         ..I TEXT="SCORES" S ORSCORES(CNT1)=$G(INPUTS(TEXT,CNT))
    61         D MHDLL^PXRMDRSG(.ORY,.ORRESULT,.ORSCORES,DFN)
    62         Q
    63         ;
    64 MHDLLDMS(ORY)   ;
    65         ;Returns a one if CPRS should used the MH dll. Returns a 0 if CPRS
    66         ;should not used the MH dll.
    67         S ORY=1
    68         I '$$PATCH^XPDUTL("YS*5.01*85") S ORY=0 Q
    69         I '$$PATCH^XPDUTL("PXRM*2.0*6") S ORY=0 Q
    70         I $$GET^XPAR("SYS","OR USE MH DLL")<1 S ORY=0 Q
    71         Q
    72         ;
    73         ;ORQQPXRM MENTAL HEALTH RESULTS
    74 MHR(ORY,RESULT,ORES)    ;
    75         ; DBIA 3080
    76         D MHR^PXRMRPCC(.ORY,RESULT,.ORES)
    77         Q
    78         ;
    79         ;ORQQPXRM MENTAL HEALTH SAVE
    80 MHS(ORY,ORES)   D MHS^PXRMRPCC(.ORY,.ORES) Q  ; DBIA 3080
    81         ;
    82 MHV(ORY,DFN,NAME,ANS)   ;
    83         N ORDATA,ORES,X
    84         S ORY(0)=0
    85         I '$$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=2 Q
    86         I '$L(ANS) Q
    87         S ORES("DFN")=DFN,ORES("CODE")=NAME
    88         F X=1:1:$L(ANS) I $E(ANS,X)'="X" D
    89         .;I $E(ANS,X)="T" S $E(ANS,X)=1
    90         .;I $E(ANS,X)="F" S $E(ANS,X)=2
    91         .S ORES(X)=X_U_$E(ANS,X)
    92         D CHECKCR^YTQPXRM4(.ORDATA,.ORES)
    93         I $G(ORDATA(2))="OK" S ORY(0)=1 Q
    94         S ORY(1)=$P($G(ORDATA(2)),U,2)
    95         Q
    96         ;
    97         ;ORQQPXRM MST UPDATE
    98 MST(ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES)  ;
    99         D MST^PXRMRPCC(.ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) Q
    100         ;
    101         ;ORQQPXRM WOMEN HEALTH RESULT
    102 WH(ORY,ORRESULT)        ;
    103         D WH^PXRMRPCC(.ORY,.ORRESULT) Q
    104         ;
    105 WHLETTER(ORY,ORIEN)     ;
    106         D LETTER^WVRPCNO1(.ORY,ORIEN) Q
    107         ;
    108 WHREPORT(ORY,ORIEN)     ;
    109         D RESULTS^WVALERTF(.ORY,ORIEN) Q
    110         ;
    111         ;ORQQPXRM DIALOG PROMPTS
    112 PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ;
    113         D PROMPT^PXRMRPCC(.ORY,ORDLG,ORDCUR,ORFTYP) Q  ; DBIA 3080
    114         ;
    115         ;ORQQPXRM REMINDER DETAIL
    116 REMDET(ORY,ORPT,ORIEN)  D REMDET^PXRMRPCA(.ORY,ORPT,ORIEN) Q  ; DBIA 3078
    117         ;
    118         ;ORQQPXRM REMINDER INQUIRY
    119 RES(ORY,ORREM)  D RES^PXRMRPCC(.ORY,ORREM) Q  ; DBIA 3080
    120         ;
    121         ;ORQQPXRM REMINDER WEB
    122 WEB(ORY,ORREM)  D WEB^PXRMRPCA(.ORY,ORREM) Q  ; DBIA 3078
    123         ;
    124         ;PXRM REMINDER DIALOG (TIU)
    125 TDIALOG(ORY,ORDLG,DFN)  ;
    126         D DIALOG^PXRMRPCD(.ORY,ORDLG,DFN)
    127         I $P($G(ORY(1)),U)=-1 Q
    128         S ORY(0)=0_U_+$P($G(^PXRMD(801.41,ORDLG,0)),U,17)
    129         Q
    130         ;
    131 ACT(REM)        ;ORQQPX SEARCH ITEMS - XPAR value screen for active reminders
    132         ;Treat a null value as inactive
    133         I 'REM Q 0
    134         ;Treat a non-existen entry as inactive
    135         I $G(^PXD(811.9,REM,0))="" Q 0
    136         ;Check IF inactive flag is set
    137         I ($T(INACTIVE^PXRM)'=""),$$INACTIVE^PXRM(REM) Q 0 ; DBIA 2182
    138         ;Otherwise active
    139         Q 1
    140         ;
    141 REMVER(ORLIST)  ;
    142         S ORLIST=$$VERSION^XPDUTL("PXRM")
    143         Q
    144         ;
    145 GEC(ORRESULT,IEN,DFN,VISIT,NOTEIEN)     ;
    146         D API^PXRMGECU(.ORRESULT,IEN,DFN,VISIT,1,NOTEIEN)
    147         Q
    148         ;
    149 GECF(RESULT,DFN,FIN)    ;
    150         D FINISHED^PXRMGECU(DFN,FIN)
    151         Q
    152         ;
    153 GECP(RESULT,DFN)        ;
    154         S RESULT=$$STATUS^PXRMGECU(DFN)
    155         Q
    156         ;
     1ORQQPXRM ; SLC/PJH - Functions for reminder data ;7/21/2005 [2/4/04 10:24am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,187,190,215**;Dec 17, 1997
     3 ;
     4 ;ORQQPXRM DIALOG ACTIVE
     5ACTIVE(ORY,ORLIST) D ACTIVE^PXRMRPCC(.ORY,.ORLIST) Q  ; DBIA 3080
     6 ;
     7 ;ORQQPXRM REMINDER EVALUATION
     8ALIST(ORY,ORPT,ORLIST) D ALIST^PXRMRPCA(.ORY,.ORPT,.ORLIST) Q  ; DBIA 3078
     9 ;
     10 ;ORQQPXRM REMINDERS APPLICABLE
     11APPL(ORY,ORPT,ORLOC) D EVALCOVR^ORQQPX(.ORY,ORPT,ORLOC) Q
     12 ;D APPL^PXRMRPCA(.ORY,ORPT,ORLOC) Q  ; DBIA 3078
     13 ;
     14 ;ORQQPXRM REMINDER CATEGORIES
     15CATEGORY(ORY,ORPT,ORLOC) ;
     16 D CATEGORY^PXRMRPCA(.ORY,ORPT,ORLOC) Q  ; DBIA 3078
     17 ;
     18 ;ORQQPXRM REMINDER DIALOG
     19DIALOG(ORY,ORREM,DFN) ;
     20 ; DBIA 3080
     21 N DIEN
     22 I $G(DFN)'="" D DIALOG^PXRMRPCC(.ORY,ORREM,DFN)
     23 I $G(DFN)="" D DIALOG^PXRMRPCC(.ORY,ORREM)
     24 I $P($G(ORY(1)),U)=-1 Q
     25 S DIEN=$G(^PXD(811.9,ORREM,51))
     26 S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17)
     27 Q
     28 ;
     29 ;ORQQPXRM EDUCATION SUBTOPICS
     30EDS(ORY,OREDU) D EDS^PXRMRPCB(.ORY,OREDU) Q  ; DBIA 3079
     31 ;
     32 ;ORQQPXRM EDUCATION SUMMARY
     33EDL(ORY,OREM) D EDL^PXRMRPCB(.ORY,OREM) Q  ; DBIA 3079
     34 ;
     35 ;ORQQPXRM EDUCATION TOPIC
     36EDU(ORY,OREDU) D EDU^PXRMRPCB(.ORY,OREDU) Q  ; DBIA 3079
     37 ;
     38 ;ORQQPXRM PROGRESS NOTE HEADER
     39HDR(ORY,ORLOC) D HDR^PXRMRPCC(.ORY,ORLOC) Q  ; DBIA 3080
     40 ;
     41 ;ORQQPXRM REMINDERS UNEVALUATED
     42LIST(ORY,ORPT,ORLOC) D GETLIST^ORQQPX(.ORY,ORLOC) Q
     43 ;D LIST^PXRMRPCA(.ORY,ORPT,ORLOC) Q  ; DBIA 3078
     44 ;
     45 ;ORQQPXRM MENTAL HEALTH
     46MH(ORY,OTEST) ;
     47 D MH^PXRMRPCC(.ORY,OTEST)  ; DBIA 3080
     48 S ORY(0)=0
     49 I $$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=1
     50 Q
     51 ;
     52 ;ORQQPXRM MENTAL HEALTH RESULTS
     53MHR(ORY,RESULT,ORES) ;
     54 ; DBIA 3080
     55 D MHR^PXRMRPCC(.ORY,RESULT,.ORES)
     56 Q
     57 ;
     58 ;ORQQPXRM MENTAL HEALTH SAVE
     59MHS(ORY,ORES) D MHS^PXRMRPCC(.ORY,.ORES) Q  ; DBIA 3080
     60 ;
     61MHV(ORY,DFN,NAME,ANS) ;
     62 N ORDATA,ORES,X
     63 S ORY(0)=0
     64 I '$$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=2 Q
     65 I '$L(ANS) Q
     66 S ORES("DFN")=DFN,ORES("CODE")=NAME
     67 F X=1:1:$L(ANS) I $E(ANS,X)'="X" D
     68 .;I $E(ANS,X)="T" S $E(ANS,X)=1
     69 .;I $E(ANS,X)="F" S $E(ANS,X)=2
     70 .S ORES(X)=X_U_$E(ANS,X)
     71 D CHECKCR^YTQPXRM4(.ORDATA,.ORES)
     72 I $G(ORDATA(2))="OK" S ORY(0)=1 Q
     73 S ORY(1)=$P($G(ORDATA(2)),U,2)
     74 Q
     75 ;
     76 ;ORQQPXRM MST UPDATE
     77MST(ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) ;
     78 D MST^PXRMRPCC(.ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) Q
     79 ;
     80 ;ORQQPXRM WOMEN HEALTH RESULT
     81WH(ORY,ORRESULT) ;
     82 D WH^PXRMRPCC(.ORY,.ORRESULT) Q
     83 ;
     84WHLETTER(ORY,ORIEN) ;
     85 D LETTER^WVRPCNO1(.ORY,ORIEN) Q
     86 ;
     87WHREPORT(ORY,ORIEN) ;
     88 D RESULTS^WVALERTF(.ORY,ORIEN) Q
     89 ;
     90 ;ORQQPXRM DIALOG PROMPTS
     91PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ;
     92 D PROMPT^PXRMRPCC(.ORY,ORDLG,ORDCUR,ORFTYP) Q  ; DBIA 3080
     93 ;
     94 ;ORQQPXRM REMINDER DETAIL
     95REMDET(ORY,ORPT,ORIEN) D REMDET^PXRMRPCA(.ORY,ORPT,ORIEN) Q  ; DBIA 3078
     96 ;
     97 ;ORQQPXRM REMINDER INQUIRY
     98RES(ORY,ORREM) D RES^PXRMRPCC(.ORY,ORREM) Q  ; DBIA 3080
     99 ;
     100 ;ORQQPXRM REMINDER WEB
     101WEB(ORY,ORREM) D WEB^PXRMRPCA(.ORY,ORREM) Q  ; DBIA 3078
     102 ;
     103 ;PXRM REMINDER DIALOG (TIU)
     104TDIALOG(ORY,ORDLG,DFN) ;
     105 D DIALOG^PXRMRPCD(.ORY,ORDLG,DFN)
     106 I $P($G(ORY(1)),U)=-1 Q
     107 S ORY(0)=0_U_+$P($G(^PXRMD(801.41,ORDLG,0)),U,17)
     108 Q
     109 ;
     110ACT(REM) ;ORQQPX SEARCH ITEMS - XPAR value screen for active reminders
     111 ;Treat a null value as inactive
     112 I 'REM Q 0
     113 ;Treat a non-existen entry as inactive
     114 I $G(^PXD(811.9,REM,0))="" Q 0
     115 ;Check IF inactive flag is set
     116 I ($T(INACTIVE^PXRM)'=""),$$INACTIVE^PXRM(REM) Q 0 ; DBIA 2182
     117 ;Otherwise active
     118 Q 1
     119 ;
     120REMVER(ORLIST) ;
     121 S ORLIST=$$VERSION^XPDUTL("PXRM")
     122 Q
     123 ;
     124GEC(ORRESULT,IEN,DFN,VISIT,NOTEIEN) ;
     125 I $$VERSION^XPDUTL("PXRM")["2.0" D API^PXRMGECU(.ORRESULT,IEN,DFN,VISIT,1,NOTEIEN)
     126 Q
     127 ;
     128GECF(RESULT,DFN,FIN) ;
     129 I $$VERSION^XPDUTL("PXRM")["2.0" D FINISHED^PXRMGECU(DFN,FIN)
     130 Q
     131 ;
     132GECP(RESULT,DFN) ;
     133 I $$VERSION^XPDUTL("PXRM")["2.0",$G(DFN)'="" S RESULT=$$STATUS^PXRMGECU(DFN)
     134 Q
     135 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUDPA.m

    r613 r623  
    1 ORUDPA  ; slc/dcm,RWF - Object (patient) lookup ;10/7/91  15:21 ; 3/7/08 5:22am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**16,243**;Dec 17, 1997;Build 242
    3 ENT     ;
    4         ;Entry: none  Exit: DFN,ORACTION,ORAGE,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORVP,ORWARD,VADPT("V"),VAERR
    5         D PATIENT^ORU1(.Y)
    6         Q
    7 EN2     ;
    8         S (ORVP,X)="",DIC(0)="EMQZI",DIC=2
    9         R !,"Select PATIENT NAME: ",X:DTIME
    10         I X=""!(X["^") S Y=-1 G END1
    11         S:'$D(DIC(0)) DIC(0)="EMQZI"
    12         S DIC="^DPT(" D ^DIC I $E(X)="^" S:X="^^" DIROUT=1 G END1
    13         I Y>0 S ORVP=+Y_";DPT(" Q:$D(ORUS)  G END1
    14         Q
    15 END1    ;
    16         I Y>0 S ^TMP("OR",$J,"PAT",1)=ORVP,^TMP("OR",$J,"PAT","B",ORVP,1)=""
    17 END     ;from ORUHDR
    18         Q:Y<0
    19         I ORVP[";DPT(" D HOMO
    20         K VA,VAROOT,VA200,VAIN,VAINDT,VAERR,VADM,DIC Q
    21         ;
    22 GPD     ;
    23         N GMRVSTR
    24         K ORPD
    25         S (ORSEQ,ORPD)=0,DFN=+ORVP
    26         I $D(^GMRD(120.51)) S X="GMRVUTL",GMRVSTR="WT" X ^%ZOSF("TEST") I $T D EN6^GMRVUTL S ORPD=+$P(X,U,8)\1
    27         S:ORPD'>0 ORPD="NF"
    28         K ORSEQ
    29         Q
    30 HOMO    ;
    31         N XQORFLG,ORCNV
    32         S DFN=+Y,VA200=1 K VAINDT
    33         D OERR^VADPT,GPD
    34         S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S(ORTS:ORTS,1:""),(ORATTEND,ORNP)=+VAIN(2),ORWARD=VAIN(4),ORL(1)=VAIN(5),(ORPV,ORL,ORL(0),ORL(2))=""
    35         I +$P(ORWARD,"^") S X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL
    36         Q
     1ORUDPA ; slc/dcm,RWF - Object (patient) lookup ;10/7/91  15:21 ;
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**16**;Dec 17, 1997
     3ENT ;
     4 ;Entry: none  Exit: DFN,ORACTION,ORAGE,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORVP,ORWARD,VADPT("V"),VAERR
     5 D PATIENT^ORU1(.Y)
     6 Q
     7EN2 ;
     8 S (ORVP,X)="",DIC(0)="EMQZI",DIC=2
     9 R !,"Select PATIENT NAME: ",X:DTIME
     10 I X=""!(X["^") S Y=-1 G END1
     11 S:'$D(DIC(0)) DIC(0)="EMQZI"
     12 S DIC="^DPT(" D ^DIC I $E(X)="^" S:X="^^" DIROUT=1 G END1
     13 I Y>0 S ORVP=+Y_";DPT(" Q:$D(ORUS)  G END1
     14 Q
     15END1 ;
     16 I Y>0 S ^TMP("OR",$J,"PAT",1)=ORVP,^TMP("OR",$J,"PAT","B",ORVP,1)=""
     17END ;from ORUHDR
     18 Q:Y<0
     19 I ORVP[";DPT(" D HOMO
     20 K VA,VAROOT,VA200,VAIN,VAINDT,VAERR,VADM,DIC Q
     21 ;
     22GPD ;
     23 K ORPD
     24 S (ORSEQ,ORPD)=0,DFN=+ORVP
     25 I $D(^GMRD(120.51)) S X="GMRVUTL" X ^%ZOSF("TEST") I $T D EN4^GMRVUTL S ORPD=+X\1
     26 S:ORPD'>0 ORPD="NF"
     27 K ORSEQ
     28 Q
     29HOMO ;
     30 N XQORFLG,ORCNV
     31 S DFN=+Y,VA200=1 K VAINDT
     32 D OERR^VADPT,GPD
     33 S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S(ORTS:ORTS,1:""),(ORATTEND,ORNP)=+VAIN(2),ORWARD=VAIN(4),ORL(1)=VAIN(5),(ORPV,ORL,ORL(0),ORL(2))=""
     34 I +$P(ORWARD,"^") S X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL
     35 S ORCNV=$$OTF^OR3CONV(+ORVP) Q:'ORCNV
     36 I ORCNV>0 W !,"DONE" H 1 Q
     37 I ORCNV<0 W $C(7),!!,$P(ORCNV,U,2) H 2 S VALMBCK="R" Q
     38 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUTL1.m

    r613 r623  
    1 ORUTL1  ; slc/dcm - OE/RR Utilities ;5/30/07  13:46
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,66,243**;Dec 17, 1997;Build 242
    3 LOC     ;Hospital Location Look-up
    4         N DIC,ORIA,ORRA
    5         S DIC=44,DIC(0)="AEQM",DIC("S")="I '$P($G(^(""OOS"")),""^"")"
    6         D ^DIC
    7         I Y<1 Q
    8         I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2)
    9         I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7),!,"  This location has been inactivated.",! K ORL G LOC
    10         Q
    11 QUE(ZTRTN,ZTDESC,ZTSAVE,ORIOPTR,ZTDTH,%ZIS,QUE,ECHO,ORION)      ;Device Handling
    12 IO      ;This entry point replaced by QUE, but left for backwards compatibility
    13         Q:'$D(ZTRTN)
    14         N IO,ION,IOP,IOPAR,IOT,ZTSK,ZTIO,POP
    15         I $G(QUE),'$L($G(ORIOPTR)) Q
    16         I $L($G(ORIOPTR)),$G(QUE),$D(ORION) S ZTIO=ORION G IOQ
    17         S:'($D(%ZIS)#2) %ZIS="Q"
    18         I $G(QUE) S:%ZIS'["Q" %ZIS=%ZIS_"Q" S %ZIS("S")="I $S($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0))'[""C-"":1,1:0)",%ZIS("B")=""
    19         I $L($G(ORIOPTR)) S IOP=ORIOPTR
    20         D ^%ZIS
    21         I POP S OREND=1 Q
    22         S ZTIO=ION
    23 IOQ     I $G(QUE)!$D(IO("Q")) D  Q
    24         . S:'$D(ZTSAVE) ZTSAVE("O*")=""
    25         . D ^%ZTLOAD
    26         . I $D(ZTSK),'$D(ECHO) W !,"REQUEST QUEUED"
    27         . I '$D(ZTSK) S OREND=1
    28         . D ^%ZISC
    29         D @ZTRTN
    30         D ^%ZISC
    31         Q
    32         ;
    33 DPI(PATCH)      ;Function returns date patch installed - added in patch 243
    34         ;PATCH is set to patch designation, for example, "SR*3.0*157"
    35         ;Output is the fileman date/time that patch was installed on this system
    36         ;A return value of -1 is given if patch hasn't been installed
    37         N ORVALUE,ORDAT,ORERR,VER,PKG,DATE,NUM
    38         S DATE=-1
    39         I '$$PATCH^XPDUTL(PATCH) Q DATE  ;If patch hasn't been installed yet quit
    40         S ORVALUE=$P(PATCH,"*") ;Package
    41         D FIND^DIC(9.4,,,"MO",.ORVALUE,,,,,"ORDAT","ORERR")
    42         S PKG=$G(ORDAT("DILIST",2,1)) I 'PKG Q DATE
    43         S ORVALUE=$P(PATCH,"*",2) ;Version
    44         D FIND^DIC(9.49,(","_PKG_","),,"X",.ORVALUE,,,,,"ORDAT","ORERR")
    45         S VER=$G(ORDAT("DILIST",2,1)) I 'VER Q DATE
    46         S ORVALUE=$P(PATCH,"*",3) ;Patch number
    47         D FIND^DIC(9.4901,(","_VER_","_PKG_","),,,.ORVALUE,,,,,"ORDAT","ORERR")
    48         S NUM=$G(ORDAT("DILIST",2,1)) I 'NUM Q DATE
    49         S DATE=$$GET1^DIQ(9.4901,(NUM_","_VER_","_PKG_","),.02,"I")
    50         Q DATE
     1ORUTL1 ; slc/dcm - OE/RR Utilities ;6/7/91  08:47
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,66**;Dec 17, 1997
     3LOC ;Hospital Location Look-up
     4 N DIC,ORIA,ORRA
     5 S DIC=44,DIC(0)="AEQM",DIC("S")="I '$P($G(^(""OOS"")),""^"")"
     6 D ^DIC
     7 I Y<1 Q
     8 I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2)
     9 I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7),!,"  This location has been inactivated.",! K ORL G LOC
     10 Q
     11QUE(ZTRTN,ZTDESC,ZTSAVE,ORIOPTR,ZTDTH,%ZIS,QUE,ECHO,ORION) ;Device Handling
     12IO ;This entry point replaced by QUE, but left for backwards compatibility
     13 Q:'$D(ZTRTN)
     14 N IO,ION,IOP,IOPAR,IOT,ZTSK,ZTIO,POP
     15 I $G(QUE),'$L($G(ORIOPTR)) Q
     16 I $L($G(ORIOPTR)),$G(QUE),$D(ORION) S ZTIO=ORION G IOQ
     17 S:'($D(%ZIS)#2) %ZIS="Q"
     18 I $G(QUE) S:%ZIS'["Q" %ZIS=%ZIS_"Q" S %ZIS("S")="I $S($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0))'[""C-"":1,1:0)",%ZIS("B")=""
     19 I $L($G(ORIOPTR)) S IOP=ORIOPTR
     20 D ^%ZIS
     21 I POP S OREND=1 Q
     22 S ZTIO=ION
     23IOQ I $G(QUE)!$D(IO("Q")) D  Q
     24 . S:'$D(ZTSAVE) ZTSAVE("O*")=""
     25 . D ^%ZTLOAD
     26 . I $D(ZTSK),'$D(ECHO) W !,"REQUEST QUEUED"
     27 . I '$D(ZTSK) S OREND=1
     28 . D ^%ZISC
     29 D @ZTRTN
     30 D ^%ZISC
     31 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCIRN.m

    r613 r623  
    1 ORWCIRN ; slc/dcm,REV - Functions for GUI CIRN ACTIONS ;22-NOV-1999 07:27:24
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,101,109,132,141,160,208,239,215,243**;October 28, 1997;Build 242
    3         ;
    4 FACLIST(ORY,ORDFN)      ; Return list of remote facilities for patient
    5         ;Check to see if CIRN PD/MPI installed
    6         N X,ORSITES,I,IFN,LOCAL,CTR,HDRFLG
    7         S X="MPIF001" X ^%ZOSF("TEST")
    8         I '$T S ORY(0)="-1^CIRN MPI not installed." Q
    9         S X="VAFCTFU1" X ^%ZOSF("TEST")
    10         I '$T S ORY(0)="-1^Remote data view not installed." Q
    11         S X=$$GET^XPAR("ALL","ORWRP CIRN REMOTE DATA ALLOW",1,"I")
    12         I 'X S ORY(0)="-1^Remote access not allowed" Q
    13         D TFL^VAFCTFU1(.ORY,ORDFN)
    14         S I=0 F  S I=$O(ORY(I)) Q:'I  I $P(ORY(I),"^",5)="OTHER",'($P(ORY(I),"^")="200HD") K ORY(I) ;Screen out Type 'OTHER' locations
    15         S HDRFLG=0
    16         I $$GET^XPAR("ALL","ORWRP CIRN SITES ALL",1,"I") D
    17         . S (CTR,I)=0
    18         . F  S I=$O(ORY(I)) Q:'I  S $P(ORY(I),"^",5)=1,CTR=CTR+1 D
    19         .. I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE"
    20         .. I $P(ORY(I),"^")="200HD" D
    21         ... I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q
    22         ... S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site.
    23         D GETLST^XPAR(.ORSITES,"ALL","ORWRP CIRN SITES","I")
    24         S (CTR,I)=0,LOCAL=$P($$SITE^VASITE,"^",3)
    25         F  S I=$O(ORY(I)) Q:'I  D
    26         . I +ORY(I)=+LOCAL K ORY(I) Q
    27         . S IFN=$$IEN^XUAF4(ORY(I)),CTR=CTR+1
    28         . I IFN,$G(ORSITES(IFN)) S $P(ORY(I),"^",5)=1 I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE"
    29         . I IFN,$G(ORSITES(IFN)),$P(ORY(I),"^")="200HD" D
    30         .. I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q
    31         .. S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site.
    32         I '$L($O(ORY(""))) S ORY(0)="-1^Only local data exists for this patient"
    33         I $G(HDRFLG),CTR'>1 K ORY(HDRFLG) S ORY(0)="-1^Only HDR has data for this patient"
    34         Q
    35 RESTRICT(ORY,PATID)     ;Check for sensitive patient
    36         N DFN,ICN,SITE
    37         I '$G(PATID) S ORY(1)="-1",ORY(2)="Invalid Patient ID" Q
    38         S ICN=$P(PATID,";",2)
    39         I 'ICN S ORY(1)="-1",ORY(2)="Invalid ICN" Q
    40         S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
    41         S DFN=+$$GETDFN^MPIF001(ICN)
    42         I DFN<0 S ORY(1)="-1",ORY(2)="Patient not found on remote system ("_SITE_")" Q
    43         D PTSEC^DGSEC4(.ORY,DFN)
    44         Q
    45 CHKLNK(ORY)     ;Check for active HL7 TCP link on local system
    46         S ORY=$$STAT^HLCSLM
    47         Q
    48 WEBADDR(ORY,PATID)      ;Get VistaWeb Address
    49         S ORY=$$GET^XPAR("ALL","ORWRP VISTAWEB ADDRESS",1,"I")
    50         I ORY="" S ORY="https://vistaweb.med.va.gov" Q
    51         I ORY="https://vistaweb.med.va.gov" Q
    52         S ORY=ORY_"?q9gtw0="_$P($$SITE^VASITE,"^",3)_"&xqi4z="_PATID_"&yiicf="_DUZ
    53         Q
    54 AUTORDV(ORY)    ;Get parameter value for ORWRP CIRN AUTOMATIC
    55         S ORY=+$$GET^XPAR("ALL","ORWRP CIRN AUTOMATIC",1,"I")
    56         Q
    57 HDRON(ORY)      ;Get parameter value for ORWRP HDR ON
    58         S ORY=+$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")
    59         Q
     1ORWCIRN ; slc/dcm,REV - Functions for GUI CIRN ACTIONS ;22-NOV-1999 07:27:24
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,101,109,132,141,160,208,239,215**;October 28, 1997
     3 ;
     4FACLIST(ORY,ORDFN) ; Return list of remote facilities for patient
     5 ;Check to see if CIRN PD/MPI installed
     6 N X,ORSITES,I,IFN,LOCAL,CTR,HDRFLG
     7 S X="MPIF001" X ^%ZOSF("TEST")
     8 I '$T S ORY(0)="-1^CIRN MPI not installed." Q
     9 S X="VAFCTFU1" X ^%ZOSF("TEST")
     10 I '$T S ORY(0)="-1^Remote data view not installed." Q
     11 S X=$$GET^XPAR("ALL","ORWRP CIRN REMOTE DATA ALLOW",1,"I")
     12 I 'X S ORY(0)="-1^Remote access not allowed" Q
     13 D TFL^VAFCTFU1(.ORY,ORDFN)
     14 S I=0 F  S I=$O(ORY(I)) Q:'I  I $P(ORY(I),"^",5)="OTHER",'($P(ORY(I),"^")="200HD") K ORY(I) ;Screen out Type 'OTHER' locations
     15 S HDRFLG=0
     16 I $$GET^XPAR("ALL","ORWRP CIRN SITES ALL",1,"I") D
     17 . S (CTR,I)=0
     18 . F  S I=$O(ORY(I)) Q:'I  S $P(ORY(I),"^",5)=1,CTR=CTR+1 D
     19 .. I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE"
     20 .. I $P(ORY(I),"^")="200HD" D
     21 ... I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q
     22 ... S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site.
     23 D GETLST^XPAR(.ORSITES,"ALL","ORWRP CIRN SITES","I")
     24 S (CTR,I)=0,LOCAL=$P($$SITE^VASITE,"^",3)
     25 F  S I=$O(ORY(I)) Q:'I  D
     26 . I +ORY(I)=+LOCAL K ORY(I) Q
     27 . S IFN=$$IEN^XUAF4(ORY(I)),CTR=CTR+1
     28 . I IFN,$G(ORSITES(IFN)) S $P(ORY(I),"^",5)=1 I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE"
     29 . I IFN,$G(ORSITES(IFN)),$P(ORY(I),"^")="200HD" D
     30 .. I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q
     31 .. S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site.
     32 I '$L($O(ORY(""))) S ORY(0)="-1^Only local data exists for this patient"
     33 I $G(HDRFLG),CTR'>1 K ORY(HDRFLG) S ORY(0)="-1^Only HDR has data for this patient"
     34 Q
     35RESTRICT(ORY,PATID) ;Check for sensitive patient
     36 N DFN,ICN,SITE
     37 I '$G(PATID) S ORY(1)="-1",ORY(2)="Invalid Patient ID" Q
     38 S ICN=$P(PATID,";",2)
     39 I 'ICN S ORY(1)="-1",ORY(2)="Invalid ICN" Q
     40 S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
     41 S DFN=+$$GETDFN^MPIF001(ICN)
     42 I DFN<0 S ORY(1)="-1",ORY(2)="Patient not found on remote system ("_SITE_")" Q
     43 D PTSEC^DGSEC4(.ORY,DFN)
     44 Q
     45CHKLNK(ORY) ;Check for active HL7 TCP link on local system
     46 S ORY=$$STAT^HLCSLM
     47 Q
     48VISTAWEB(ORY)   ;Check VistaWeb Parameter
     49 S ORY=+$$GET^XPAR("ALL","ORWRP VISTAWEB",1,"I")
     50 Q
     51WEBCH(ORY,ORVALUE)      ;Change value of ORWRP VISTAWEB parameter
     52 D PUT^XPAR(DUZ_";VA(200,","ORWRP VISTAWEB",1,ORVALUE)
     53 Q
     54WEBADDR(ORY,PATID)      ;Get VistaWeb Address
     55 S ORY=$$GET^XPAR("ALL","ORWRP VISTAWEB ADDRESS",1,"I")
     56 I ORY="" S ORY="https://vistaweb.med.va.gov" Q
     57 I ORY="https://vistaweb.med.va.gov" Q
     58 S ORY=ORY_"?q9gtw0="_$P($$SITE^VASITE,"^",3)_"&xqi4z="_PATID_"&yiicf="_DUZ
     59 Q
     60AUTORDV(ORY) ;Get parameter value for ORWRP CIRN AUTOMATIC
     61 S ORY=+$$GET^XPAR("ALL","ORWRP CIRN AUTOMATIC",1,"I")
     62 Q
     63HDRON(ORY)      ;Get parameter value for ORWRP HDR ON
     64 S ORY=+$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")
     65 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCV.m

    r613 r623  
    1 ORWCV   ; SLC/KCM - Background Cover Sheet Load; ; 3/6/08 6:34am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 4011    Access ^XWB(8994)
    5         ; DBIA 4313    Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT")
    6         ; DBIA 10061   Reference to ^UTILITY
    7         ;
    8 START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM)  ; start cover sheet build in background
    9         N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX
    10         ; Capacity planning timing code uses ORHTIME
    11         S ORHTIME=$H
    12         S LOC=$G(LOC),NODO=";"_$G(NODO),NEWREM=+$G(NEWREM)
    13         D GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q")
    14         S I=0 F  S I=$O(ORX(I)) Q:'I  I $D(^ORD(101.24,+ORX(I),0)) S SECT(+$P(^(0),"^",2))=$P(ORX(I),"^",2)
    15         D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST")
    16         S (VAL,BACK,STR,FILE)=""
    17         F  S I=$O(ORLIST(I)) Q:'I  I $D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  S X0=^(0) D
    18         . Q:$P(X0,"^",8)'="C"
    19         . S X=$P(X0,"^",2)
    20         . I NODO[(";"_X_";") Q                                  ; if in NODO, dont do section
    21         . S STR=STR_X_";"
    22         . I '$G(SECT(X)) S VAL=VAL_X_";"                        ; load section in foreground
    23         . E  S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),"^",2)_";"  ; load section in background
    24         Q:BACK=""
    25         S ZTIO="ORW THREAD RESOURCE",ZTRTN="BUILD^ORWCV",ZTDTH=$H
    26         S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))=""
    27         S ZTDESC="CPRS GUI Background Data Retrieval"
    28         D ^%ZTLOAD I '$D(ZTSK) S VAL=STR Q
    29         S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
    30         K ^XTMP(NODE)
    31         S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK
    32         ; Start capacity planning timing clock - will be stopped in POLL code
    33         I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM"))
    34         Q
    35 BUILD   ; called in background by task manager, expects DFN, JobID
    36         N NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2
    37         S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
    38         I $D(ZTQUEUED) S ZTREQ="@"
    39         I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q  ; client no longer polling
    40         I '$D(^XTMP(NODE,0)) Q                    ; XTMP node has been purged
    41         L +^XTMP(NODE)
    42         S ^XTMP(NODE,"DFN")=DFN
    43         ;N $ETRAP,$ESTACK
    44         ;S $ETRAP="D ERR^ORWCV Q"
    45         I $L($G(FILE),";")>0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE)  Q:'$D(^ORD(101.24,+ORFNUM,0))  S X0=^(0),X2=$G(^(2)) D
    46         . S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL=""
    47         . I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^")  ;DBIA 4011
    48         . I '$L(INODE) Q
    49         . I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
    50         . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
    51         . I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
    52         . I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D  D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q  ;Special case for reminders
    53         .. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1
    54         .. E  D @(ENT_"^"_RTN_"(.LST,DFN)")
    55         .. D LST2XTMP(INODE)
    56         . I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q
    57         . I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q
    58         . D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE)
    59         S ^XTMP(NODE,"DONE")=1
    60         I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE)
    61         L -^XTMP(NODE)
    62         Q
    63 ERR     ;Error trap
    64         S $ETRAP="D UNWIND^ORWCV Q"
    65         I $D(NODE) D
    66         . I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE)
    67         . S ^XTMP(NODE,"DONE")=1
    68         . L -^XTMP(NODE)
    69         D @^%ZOSF("ERRTN") ;file error
    70         S $ECODE=",UOR70 error during Cover Sheet build,"
    71         Q
    72 UNWIND  ;Unwind Error stack
    73         Q:$ESTACK>1  ;pop the stack
    74         ;add additional code here, if needed
    75         Q
    76 LST2XTMP(ID)    ; put the list in ^XTMP(NODE,ID)
    77         I $G(^XTMP(NODE,"STOP")) Q
    78         N I
    79         I $L($G(DETAIL)) S I=0 F  S I=$O(LST(I)) Q:'I  S $P(LST(I),"^",12)=DETAIL
    80         K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST
    81         Q
    82 POLL(LST,DFN,IP,HWND)   ; poll for completed cover sheet parts
    83         N I,ILST,ID,NODE,DONE
    84         S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0
    85         I '$D(^XTMP(NODE,"DFN")) Q
    86         I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q
    87         I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1
    88         F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D
    89         . I '$G(^XTMP(NODE,ID)) Q
    90         . S ILST=ILST+1,LST(ILST)="~"_ID
    91         . S I=0 F  S I=$O(^XTMP(NODE,ID,I)) Q:'I  S ILST=ILST+1,LST(ILST)="i"_^(I)
    92         . K ^XTMP(NODE,ID)
    93         ; Stop capacity planning timing clock - was started in START code
    94         I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H
    95         Q
    96 STOP(OK,DFN,IP,HWND)    ; stop cover sheet data retrieval
    97         S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0
    98         S ^XTMP(NODE,"STOP")=1,OK=1
    99         L +^XTMP(NODE)
    100         I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE)
    101         L -^XTMP(NODE)
    102         Q
    103 CLEAN   ; clean up ^XTMP nodes
    104         S X="ORWCV"
    105         F  S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV"  W !,X K ^XTMP(X)
    106         Q
    107 LAB(LST,DFN)    ; return labs for patient
    108         D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1
    109         D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1)
    110         D:$L($T(END^AWCMCPR1)) END^AWCMCPR1
    111         Q
    112         ;
    113 VST1(ORVISIT,DFN,BEG,END,SKIP)  ;
    114         N ERR,ERRMSG
    115         S ERR=0 ; kludge to return errors
    116         Q:'$G(DFN)
    117         D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG)
    118         I ERR K ORVISIT S ORVISIT(1)=ERRMSG
    119         Q
    120         ;
    121 TEST    ;D VST(.ZZZ,76,2950101,3050401,777,1,1)
    122         Q
    123 VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG)        ; return appts/admissions for patient
    124         N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X
    125         S CHECKERR=($G(ERR)=0) ; kludge to check for errors
    126         S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
    127         I '$G(BEG) S BEG=$$X2FM($$RNGVBEG)
    128         I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359
    129         S COUNT=0
    130         K ^TMP("ORVSTLIST",$J)
    131         S VAERR=0
    132         I END>NOW D   Q:VAERR  ; get future encounters, past cancels/no-shows from VADPT
    133         . S VASD("F")=BEG
    134         . S VASD("T")=END
    135         . S VASD("W")="123456789"
    136         . D SDA^ORQRY01(.ERR,.ERRMSG)
    137         . I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q  ;IA 10061
    138         . S I=0 F  S I=$O(^UTILITY("VASD",$J,I)) Q:'I  D
    139         . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
    140         . . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3)
    141         . . S LOC=$P(XE,U,2),STS=$P(XE,U,3)
    142         . . I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q  ; no prior kept appts
    143         . . S ^TMP("ORVSTLIST",$J,DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS
    144         . K ^UTILITY("VASD",$J)
    145         I BEG'>NOW D  ;past encounters from ACRP Toolkit - set in CALLBACK
    146         . S BDT=BEG
    147         . S EDT=$S(END<NOW:END,1:NOW)
    148         . D OPEN^SDQ(.ORQUERY)
    149         . I '$$ERRCHK^SDQUT() D INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET")
    150         . I '$$ERRCHK^SDQUT() D PAT^SDQ(.ORQUERY,DFN,"SET")
    151         . I '$$ERRCHK^SDQUT() D DATE^SDQ(.ORQUERY,BDT,EDT,"SET")
    152         . I '$$ERRCHK^SDQUT() D
    153         . . S ORLST=$NA(^TMP("ORVSTLIST",$J))
    154         . . D SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET")
    155         . I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.ORQUERY,"TRUE","SET")
    156         . I '$$ERRCHK^SDQUT() D SCAN^SDQ(.ORQUERY,"FORWARD")
    157         . D CLOSE^SDQ(.ORQUERY)
    158         ;
    159         I '$G(SKIP) D
    160         . N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE                ; admits
    161         . S EARLY=$$X2FM($$RNGVBEG),DONE=0
    162         . S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D  Q:DONE
    163         . . S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D  Q:DONE
    164         . . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U)
    165         . . . I MTIM<EARLY S DONE=1 Q
    166         . . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
    167         . . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
    168         . . . S ^TMP("ORVSTLIST",$J,MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP
    169         ;
    170         S COUNT=0
    171         S I=0 F  S I=$O(^TMP("ORVSTLIST",$J,I)) Q:'I  D
    172         . S J="" F  S J=$O(^TMP("ORVSTLIST",$J,I,J)) Q:J=""  D
    173         . . S K=0 F  S K=$O(^TMP("ORVSTLIST",$J,I,J,K)) Q:'K  D
    174         . . . S COUNT=COUNT+1
    175         . . . S ORVISIT(COUNT)=^TMP("ORVSTLIST",$J,I,J,K)
    176         K ^TMP("ORVSTLIST",$J)
    177         Q
    178 CALLBACK(IEN,NODE0,ARRAY,STOP)  ; called back from ACRP Toolkit for encounters
    179         ;
    180         ; IEN and NODE0 relate to Outpatient Encounter File
    181         ; set STOP to 1 if need to quit
    182         ;
    183         N COUNT,DTM,LOC,OOS,TYPE,XSTAT,XLOC
    184         S DTM=+NODE0,COUNT=1
    185         S LOC=$P(NODE0,"^",4)
    186         S XLOC=$P($G(^SC(+LOC,0)),U),OOS=$G(^("OOS"))
    187         I OOS Q              ; ignore OOS locations
    188         I $P(NODE0,"^",6) Q  ; not parent encounter
    189         S XSTAT=$P($G(^SD(409.63,+$P(NODE0,"^",12),0)),"^")
    190         S TYPE=$S($P(NODE0,"^",8)=1:"A",1:"V")
    191         I TYPE="V",$D(@ARRAY@(DTM,"V")) S COUNT=$O(@ARRAY@(DTM,"V","A"),-1)+1 ; same d/t
    192         S @ARRAY@(DTM,TYPE,COUNT)=TYPE_";"_DTM_";"_LOC_U_DTM_U_XLOC_U_XSTAT
    193         Q
    194 DTLVST(RPT,DFN,IEN,APPTINFO)    ; return progress notes / discharge summary
    195         N VISIT
    196         I $P(APPTINFO,";")="A" D  Q
    197         . S VISIT=$$APPT2VST^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
    198         . I VISIT=0 S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
    199         . D DETNOTE^ORQQVS(.RPT,DFN,VISIT)
    200         I $P(APPTINFO,";")="V" D  Q
    201         . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
    202         . D DETNOTE^ORQQVS(.RPT,DFN,VISIT)
    203         I $P(APPTINFO,";")="I" D  Q
    204         . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
    205         . D DETSUM^ORQQVS(.RPT,DFN,VISIT)
    206         . K ^TMP("PXKENC",$J)
    207         Q
    208 X2FM(X) ; return FM date given relative date
    209         N %DT S %DT="TS" D ^%DT
    210         Q Y
    211 RNGLAB(DFN)     ; return days back for patient
    212         N INPT,PAR
    213         S INPT=0 I $L($G(^DPT(DFN,.1))) S INPT=1
    214         S PAR="ORQQLR DATE RANGE "_$S(INPT:"INPT",1:"OUTPT")
    215         Q $$GET^XPAR("ALL",PAR,1,"I")
    216         ;
    217 RNGVBEG()       ; return start date for encounters
    218         Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE START",1,"I")
    219         ;
    220 RNGVEND()       ; return stop date for encounters
    221         Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE STOP",1,"I")
    222         ;
    223 RANGES(REC,DFN) ; return ranges given a patient
    224         N REC
    225         S REC=$$RNGLAB(DFN)_U_$$RNGVBEG_U_$$RNGVEND
    226         Q
     1ORWCV ; SLC/KCM - Background Cover Sheet Load; ;11/2/06  15:07
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260**;Dec 17, 1997;Build 26
     3 ;
     4 ; DBIA 4011    Access ^XWB(8994)
     5 ; DBIA 4313    Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT")
     6 ; DBIA 10061   Reference to ^UTILITY
     7 ;
     8START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background
     9 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX
     10 ; Capacity planning timing code uses ORHTIME
     11 S ORHTIME=$H
     12 S LOC=$G(LOC),NODO=";"_$G(NODO),NEWREM=+$G(NEWREM)
     13 D GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q")
     14 S I=0 F  S I=$O(ORX(I)) Q:'I  I $D(^ORD(101.24,+ORX(I),0)) S SECT(+$P(^(0),"^",2))=$P(ORX(I),"^",2)
     15 D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST")
     16 S (VAL,BACK,STR,FILE)=""
     17 F  S I=$O(ORLIST(I)) Q:'I  I $D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  S X0=^(0) D
     18 . Q:$P(X0,"^",8)'="C"
     19 . S X=$P(X0,"^",2)
     20 . I NODO[(";"_X_";") Q                                  ; if in NODO, dont do section
     21 . S STR=STR_X_";"
     22 . I '$G(SECT(X)) S VAL=VAL_X_";"                        ; load section in foreground
     23 . E  S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),"^",2)_";"  ; load section in background
     24 Q:BACK=""
     25 S ZTIO="ORW THREAD RESOURCE",ZTRTN="BUILD^ORWCV",ZTDTH=$H
     26 S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))=""
     27 S ZTDESC="CPRS GUI Background Data Retrieval"
     28 D ^%ZTLOAD I '$D(ZTSK) S VAL=STR Q
     29 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
     30 K ^XTMP(NODE)
     31 S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK
     32 ; Start capacity planning timing clock - will be stopped in POLL code
     33 I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM"))
     34 Q
     35BUILD ; called in background by task manager, expects DFN, JobID
     36 N NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2
     37 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
     38 I $D(ZTQUEUED) S ZTREQ="@"
     39 I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q  ; client no longer polling
     40 I '$D(^XTMP(NODE,0)) Q                    ; XTMP node has been purged
     41 L +^XTMP(NODE)
     42 S ^XTMP(NODE,"DFN")=DFN
     43 ;N $ETRAP,$ESTACK
     44 ;S $ETRAP="D ERR^ORWCV Q"
     45 I $L($G(FILE),";")>0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE)  Q:'$D(^ORD(101.24,+ORFNUM,0))  S X0=^(0),X2=$G(^(2)) D
     46 . S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL=""
     47 . I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^")  ;DBIA 4011
     48 . I '$L(INODE) Q
     49 . I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
     50 . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
     51 . I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
     52 . I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D  D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q  ;Special case for reminders
     53 .. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1
     54 .. E  D @(ENT_"^"_RTN_"(.LST,DFN)")
     55 .. D LST2XTMP(INODE)
     56 . I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q
     57 . I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q
     58 . D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE)
     59 S ^XTMP(NODE,"DONE")=1
     60 I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE)
     61 L -^XTMP(NODE)
     62 Q
     63ERR ;Error trap
     64 S $ETRAP="D UNWIND^ORWCV Q"
     65 I $D(NODE) D
     66 . I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE)
     67 . S ^XTMP(NODE,"DONE")=1
     68 . L -^XTMP(NODE)
     69 D @^%ZOSF("ERRTN") ;file error
     70 S $ECODE=",UOR70 error during Cover Sheet build,"
     71 Q
     72UNWIND ;Unwind Error stack
     73 Q:$ESTACK>1  ;pop the stack
     74 ;add additional code here, if needed
     75 Q
     76LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID)
     77 I $G(^XTMP(NODE,"STOP")) Q
     78 N I
     79 I $L($G(DETAIL)) S I=0 F  S I=$O(LST(I)) Q:'I  S $P(LST(I),"^",12)=DETAIL
     80 K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST
     81 Q
     82POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts
     83 N I,ILST,ID,NODE,DONE
     84 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0
     85 I '$D(^XTMP(NODE,"DFN")) Q
     86 I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q
     87 I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1
     88 F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D
     89 . I '$G(^XTMP(NODE,ID)) Q
     90 . S ILST=ILST+1,LST(ILST)="~"_ID
     91 . S I=0 F  S I=$O(^XTMP(NODE,ID,I)) Q:'I  S ILST=ILST+1,LST(ILST)="i"_^(I)
     92 . K ^XTMP(NODE,ID)
     93 ; Stop capacity planning timing clock - was started in START code
     94 I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H
     95 Q
     96STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval
     97 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0
     98 S ^XTMP(NODE,"STOP")=1,OK=1
     99 L +^XTMP(NODE)
     100 I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE)
     101 L -^XTMP(NODE)
     102 Q
     103CLEAN ; clean up ^XTMP nodes
     104 S X="ORWCV"
     105 F  S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV"  W !,X K ^XTMP(X)
     106 Q
     107LAB(LST,DFN) ; return labs for patient
     108 D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1
     109 D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1)
     110 D:$L($T(END^AWCMCPR1)) END^AWCMCPR1
     111 Q
     112 ;
     113VST1(ORVISIT,DFN,BEG,END,SKIP) ;
     114 N ERR,ERRMSG
     115 S ERR=0 ; kludge to return errors
     116 D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG)
     117 I ERR K ORVISIT S ORVISIT(1)=ERRMSG
     118 Q
     119 ;
     120TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1)
     121 Q
     122VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient
     123 N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X
     124 S CHECKERR=($G(ERR)=0) ; kludge to check for errors
     125 S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
     126 I '$G(BEG) S BEG=$$X2FM($$RNGVBEG)
     127 I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359
     128 S COUNT=0
     129 K ^TMP("ORVSTLIST",$J)
     130 S VAERR=0
     131 I END>NOW D   Q:VAERR  ; get future encounters, past cancels/no-shows from VADPT
     132 . S VASD("F")=BEG
     133 . S VASD("T")=END
     134 . S VASD("W")="123456789"
     135 . D SDA^ORQRY01(.ERR,.ERRMSG)
     136 . I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q  ;IA 10061
     137 . S I=0 F  S I=$O(^UTILITY("VASD",$J,I)) Q:'I  D
     138 . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
     139 . . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3)
     140 . . S LOC=$P(XE,U,2),STS=$P(XE,U,3)
     141 . . I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q  ; no prior kept appts
     142 . . S ^TMP("ORVSTLIST",$J,DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS
     143 . K ^UTILITY("VASD",$J)
     144 I BEG'>NOW D  ;past encounters from ACRP Toolkit - set in CALLBACK
     145 . S BDT=BEG
     146 . S EDT=$S(END<NOW:END,1:NOW)
     147 . D OPEN^SDQ(.ORQUERY)
     148 . I '$$ERRCHK^SDQUT() D INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET")
     149 . I '$$ERRCHK^SDQUT() D PAT^SDQ(.ORQUERY,DFN,"SET")
     150 . I '$$ERRCHK^SDQUT() D DATE^SDQ(.ORQUERY,BDT,EDT,"SET")
     151 . I '$$ERRCHK^SDQUT() D
     152 . . S ORLST=$NA(^TMP("ORVSTLIST",$J))
     153 . . D SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET")
     154 . I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.ORQUERY,"TRUE","SET")
     155 . I '$$ERRCHK^SDQUT() D SCAN^SDQ(.ORQUERY,"FORWARD")
     156 . D CLOSE^SDQ(.ORQUERY)
     157 ;
     158 I '$G(SKIP) D
     159 . N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE                ; admits
     160 . S EARLY=$$X2FM($$RNGVBEG),DONE=0
     161 . S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D  Q:DONE
     162 . . S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D  Q:DONE
     163 . . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U)
     164 . . . I MTIM<EARLY S DONE=1 Q
     165 . . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
     166 . . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
     167 . . . S ^TMP("ORVSTLIST",$J,MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP
     168 ;
     169 S COUNT=0
     170 S I=0 F  S I=$O(^TMP("ORVSTLIST",$J,I)) Q:'I  D
     171 . S J="" F  S J=$O(^TMP("ORVSTLIST",$J,I,J)) Q:J=""  D
     172 . . S K=0 F  S K=$O(^TMP("ORVSTLIST",$J,I,J,K)) Q:'K  D
     173 . . . S COUNT=COUNT+1
     174 . . . S ORVISIT(COUNT)=^TMP("ORVSTLIST",$J,I,J,K)
     175 K ^TMP("ORVSTLIST",$J)
     176 Q
     177CALLBACK(IEN,NODE0,ARRAY,STOP) ; called back from ACRP Toolkit for encounters
     178 ;
     179 ; IEN and NODE0 relate to Outpatient Encounter File
     180 ; set STOP to 1 if need to quit
     181 ;
     182 N COUNT,DTM,LOC,OOS,TYPE,XSTAT,XLOC
     183 S DTM=+NODE0,COUNT=1
     184 S LOC=$P(NODE0,"^",4)
     185 S XLOC=$P($G(^SC(+LOC,0)),U),OOS=$G(^("OOS"))
     186 I OOS Q              ; ignore OOS locations
     187 I $P(NODE0,"^",6) Q  ; not parent encounter
     188 S XSTAT=$P($G(^SD(409.63,+$P(NODE0,"^",12),0)),"^")
     189 S TYPE=$S($P(NODE0,"^",8)=1:"A",1:"V")
     190 I TYPE="V",$D(@ARRAY@(DTM,"V")) S COUNT=$O(@ARRAY@(DTM,"V","A"),-1)+1 ; same d/t
     191 S @ARRAY@(DTM,TYPE,COUNT)=TYPE_";"_DTM_";"_LOC_U_DTM_U_XLOC_U_XSTAT
     192 Q
     193DTLVST(RPT,DFN,IEN,APPTINFO) ; return progress notes / discharge summary
     194 N VISIT
     195 I $P(APPTINFO,";")="A" D  Q
     196 . S VISIT=$$APPT2VST^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
     197 . I VISIT=0 S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
     198 . D DETNOTE^ORQQVS(.RPT,DFN,VISIT)
     199 I $P(APPTINFO,";")="V" D  Q
     200 . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
     201 . D DETNOTE^ORQQVS(.RPT,DFN,VISIT)
     202 I $P(APPTINFO,";")="I" D  Q
     203 . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
     204 . D DETSUM^ORQQVS(.RPT,DFN,VISIT)
     205 . K ^TMP("PXKENC",$J)
     206 Q
     207X2FM(X) ; return FM date given relative date
     208 N %DT S %DT="TS" D ^%DT
     209 Q Y
     210RNGLAB(DFN) ; return days back for patient
     211 N INPT,PAR
     212 S INPT=0 I $L($G(^DPT(DFN,.1))) S INPT=1
     213 S PAR="ORQQLR DATE RANGE "_$S(INPT:"INPT",1:"OUTPT")
     214 Q $$GET^XPAR("ALL",PAR,1,"I")
     215 ;
     216RNGVBEG() ; return start date for encounters
     217 Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE START",1,"I")
     218 ;
     219RNGVEND() ; return stop date for encounters
     220 Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE STOP",1,"I")
     221 ;
     222RANGES(REC,DFN) ; return ranges given a patient
     223 N REC
     224 S REC=$$RNGLAB(DFN)_U_$$RNGVBEG_U_$$RNGVEND
     225 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWD.m

    r613 r623  
    1 ORWD    ; SLC/KCM - Utilities for Windows Dialogs ;7/2/01  13:31
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
    3         ;
    4 DT(Y,X) ; Returns internal Fileman Date/Time
    5         N %DT S %DT="TS" D ^%DT
    6         Q
    7 PROVKEY(VAL,USERID)     ; Returns 1 if user possesses the provider key
    8         N NAM S NAM=$P(^VA(200,USERID,0),U,1)
    9         S VAL=$D(^VA(200,"AK.PROVIDER",NAM,USERID))
    10         Q
    11 KEY(VAL,KEYNAME,USERID) ; Returns 1 if user possesses the key
    12         S VAL=0 I $D(^XUSEC(KEYNAME,USERID)) S VAL=1
    13         Q
    14 OI(Y,XREF,DIR,FROM)     ; Return a bolus of orderable items
    15         ; .Return Array, Cross Reference (S.xxx), Direction, Starting Text
    16         N I,IEN,CNT S CNT=44
    17         ;
    18         I DIR=0 D  ; Forward direction
    19         . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM)) Q:FROM=""  D
    20         . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM
    21         . I $G(Y(CNT))="" S Y(I)=""
    22         ;
    23         I DIR=1 D  ; Reverse direction
    24         . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM),-1) Q:FROM=""  D
    25         . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM
    26         Q
    27 ODEF(Y,DLG)     ; Return the definition for a dialog
    28         Q:'$L(DLG)
    29         S DLG=+$O(^ORD(101.41,"B",DLG,0))
    30         Q:$D(^ORD(101.41,DLG,50))<10
    31         N I,IEN,IDX
    32         S I=0,IDX=0
    33         S Y(0)=$P($G(^ORD(101.41,DLG,5)),"^",4)
    34         F  S I=$O(^ORD(101.41,DLG,50,"AC",I)) Q:I=""  S IEN=$O(^(I,0)) D
    35         . S IDX=IDX+1,Y(IDX)=$G(^ORD(101.41,DLG,50,IEN,0))
    36         Q
    37 DEF(Y,DLG)      ; Return format mapping for a dialog
    38         ; Y(n): CtrlName^DlgPtr^FmtSeq^Fmt^Omit^Lead^Trail^Mult?^chd1~chd2~...
    39         I DLG="NOT IMPLEMENTED" S Y(0)="0^0" Q                 ; for testing
    40         S DLG=$O(^ORD(101.41,"B",DLG,0))
    41         N I,J,K,N,X0,X2,XW,DPTR
    42         S Y(0)=$P(^ORD(101.41,DLG,0),U,5)_U_DLG
    43         S I=0,N=0
    44         F  S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0  D
    45         . S X0=$G(^ORD(101.41,DLG,10,I,0)),DPTR=$P(X0,U,2)
    46         . S X2=$G(^ORD(101.41,DLG,10,I,2))
    47         . S XW=$G(^ORD(101.41,DLG,10,I,"W"))
    48         . S N=N+1,Y(N)=$P(XW,U,1)_U_DPTR_U_X2,CHLD=""
    49         . S J=0 F  S J=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J)) Q:'J  D
    50         . . S K=0 F  S K=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J,K)) Q:'K  D
    51         . . . S CHLD=CHLD_$P(^ORD(101.41,DLG,10,K,0),U,2)_"~"
    52         . S $P(Y(N),U,8)=CHLD
    53         Q
    54 FORMID(VAL,ORIFN)       ; procedure
    55         ; Returns the Dialog Form ID
    56         N X
    57         S VAL=0,X=$P(^OR(100,+ORIFN,0),U,5)
    58         Q:$P(X,";",2)'="ORD(101.41,"
    59         S VAL=+$P($G(^ORD(101.41,+X,5)),U,5)
    60         ; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2)
    61         Q
    62 GET4EDIT(LST,ORIFN)     ; procedure
    63         ; return responses in format that can be used by dialog
    64         N ILST,PRMT,INST,DLG,ORDIALOG S ILST=0
    65         I '$D(ORIFN) S LST=0 Q
    66         S ORIFN=+ORIFN,DLG=+$P(^OR(100,ORIFN,0),U,5)
    67         D GETDLG1^ORCD(DLG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)")
    68         S PRMT=0 F  S PRMT=$O(ORDIALOG(PRMT)) Q:'PRMT  D
    69         . S INST=0 F  S INST=$O(ORDIALOG(PRMT,INST)) Q:'INST  D
    70         . . S ILST=ILST+1,LST(ILST)="~"_PRMT_U_INST_U_$P(ORDIALOG(PRMT),U,3)
    71         . . S ILST=ILST+1,LST(ILST)="d"_ORDIALOG(PRMT,INST)
    72         . . I $E(ORDIALOG(PRMT,INST))=U D                 ; load word processing
    73         . . . N I,REF S I=0,REF=ORDIALOG(PRMT,INST)
    74         . . . F  S I=$O(@REF@(I)) Q:'I  S ILST=ILST+1,LST(ILST)="t"_^(I,0)
    75         . . E  S $P(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST)  ; load external value
    76         . . I "R"[$E(ORDIALOG(PRMT,0)) D
    77         . . . S $P(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST)))
    78         Q
    79 EXTDT(X)        ; Return an external date time that can be interpreted by %DT
    80         I $E(X)="T" Q "TODAY"_$E(X,2,255)
    81         I $E(X)="V" Q "NEXT VISIT"_$E(X,2,255)
    82         Q ""
    83 WRLST(Y,TYP)    ; Return list of dialogs for writing orders
    84         ; .Y(n): DlgName^ListBox Text
    85         ;   TYP: 'I' = inpatient, 'O' = outpatient
    86         N PAR,ERR,SEQ,IEN,I,X
    87         S PAR=$S(TYP="I":"ORW ADDORD INPT",1:"ORW ADDORD OUTPT")
    88         D GETLST^XPAR(.X,"ALL",PAR,"Q",.ERR) Q:ERR
    89         S I=0 F  S I=$O(X(I)) Q:'I  D
    90         . S SEQ=$P(X(I),U,1),IEN=$P(X(I),U,2)
    91         . S Y(SEQ)=$P(^ORD(101.41,IEN,0),U,1)_U_$P($G(^(5)),U,4)
    92         Q
    93 SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP)    ; procedure
    94         ; Save order
    95         N ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA
    96         I $P(^ORD(101.41,+DLG,0),U)="PSO OERR" S ORCAT="O"
    97         I $P(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE" S ORCAT="I"
    98         S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2)
    99         D GETDLG^ORCD(DLG)
    100         M ORDIALOG=RSP S ORDIALOG=DLG
    101         I ORWDACT="N" D
    102         . D EN^ORCSAVE
    103         . S Y="" I ORIFN D GETBYIFN^ORWORR(.Y,ORIFN)
    104         I $P(ORWDACT,U,1)="E" D
    105         . S ORIFN=+$P(ORWDACT,U,2) D XX^ORCSAVE
    106         . S Y="" S ORIFN=+$P(ORWDACT,U,2)_";"_ORDA D GETBYIFN^ORWORR(.Y,ORIFN)
    107         Q
    108 SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN)       ; procedure
    109         ; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR)
    110         N ORVP,ORL,IDX,ANERROR,ERRCNT
    111         S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2),ERRCNT=0
    112         I '$D(^XUSEC("ORES",DUZ)) S ERRLST(1)=0_U_"Must have ORES key." Q
    113         S IDX=0 F  S IDX=$O(ORWSIGN(IDX)) Q:'IDX  S X=ORWSIGN(IDX) D
    114         . ; ** change NATR when GUI changed to pass Nature in 4th piece
    115         . S ORIFN=$P(X,U),RELSTS=$P(X,U,2),SIGSTS=$P(X,U,3),NATR="E" ;$P(X,U,4)
    116         . I SIGSTS=2 D NOTIF^ORCSIGN S ANERROR=""
    117         . I SIGSTS'=2 D EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR)
    118         . I $L(ANERROR) D  Q           ; don't print if an error occurred
    119         . . S ERRCNT=ERRCNT+1,ERRLST(ERRCNT)=$P(ORWSIGN(IDX),U)_U_ANERROR
    120         . . K ORWSIGN(IDX)
    121         . I RELSTS=0 K ORWSIGN(IDX) Q  ; don't print if unreleased
    122         . S ORWSIGN(IDX)=$P(ORWSIGN(IDX),U)
    123         D PRINTS^ORWD1(.ORWSIGN,LOC)
    124         Q
    125 VALIDACT(VAL,ORIFN,ACTION)      ;procedure
    126         ; Return 1 if action is valid for this order, otherwise 0^error
    127         S VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR)
    128         I VAL=0 S VAL=VAL_U_ERR
    129         Q
    130 SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC)   ;procedure
    131         ; Save this action for the order (it is still unsigned/unreleased)
    132         N ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS
    133         S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC("
    134         S SIGSTS=2,RELSTS=11
    135         I '$P(ORIFN,";",2) S $P(ORIFN,";",2)=1
    136         I (ACTION="FL")!(ACTION="UF")!(ACTION="WC") S SIGSTS=3,RELSTS=""
    137         S ASTS=$P(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0),U,15)
    138         I ACTION="DC",((ASTS=10)!(ASTS=11)) D  Q       ; exit here if DELETE
    139         . D GETBYIFN^ORWORR(.LST,ORIFN)
    140         . S $P(LST(1),U,1)="~0",LST(2)="tDELETED - "_$E(LST(2),2,245)
    141         . D CANCEL^ORCSAVE2(ORIFN)
    142         ;
    143         ; the only valid action for ActDA>1 is deletion, so only orders
    144         ; identified by ORIFN;1 should reach this point
    145         ;
    146         I $P(ORIFN,";",2)>1 S $ECODE=",Uorder action invalid," Q
    147         I ACTION="FL" S $P(^OR(100,+ORIFN,6),U,1)=1
    148         I ACTION="UF" S $P(^OR(100,+ORIFN,6),U,1)=0
    149         I ACTION'="RN" D
    150         . S ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON)
    151         I ACTION="RN" D
    152         . N ORDA,ORDIALOG,PRMT,SAVIFN,X0
    153         . S SAVIFN=+ORIFN,X0=^OR(100,+ORIFN,0)
    154         . I $P(X0,U,5)["101.41," D                        ; version 3
    155         . . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
    156         . . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
    157         . E  D                                            ; version 2.5 generic
    158         . . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
    159         . . D GETDLG^ORCD(ORDIALOG)
    160         . . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
    161         . . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
    162         . . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
    163         . . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
    164         . . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
    165         . D RN^ORCSAVE I 'ORIFN S $ECODE=",UCPRS renew order,"
    166         . S ACTDA=ORDA,ORIFN=SAVIFN
    167         I (ACTION="FL")!(ACTION="UF") S ACTDA=1
    168         D GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA)
    169         S $P(LST(1),U,12)=ACTDA
    170         Q
     1ORWD ; SLC/KCM - Utilities for Windows Dialogs ;7/26/96  17:53 [ 11/19/96  4:27 PM ]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
     3 ;
     4DT(Y,X) ; Returns internal Fileman Date/Time
     5 N %DT S %DT="TS" D ^%DT
     6 Q
     7PROVKEY(VAL,USERID)       ; Returns 1 if user possesses the provider key
     8 N NAM S NAM=$P(^VA(200,USERID,0),U,1)
     9 S VAL=$D(^VA(200,"AK.PROVIDER",NAM,USERID))
     10 Q
     11KEY(VAL,KEYNAME,USERID) ; Returns 1 if user possesses the key
     12 S VAL=0 I $D(^XUSEC(KEYNAME,USERID)) S VAL=1
     13 Q
     14OI(Y,XREF,DIR,FROM) ; Return a bolus of orderable items
     15 ; .Return Array, Cross Reference (S.xxx), Direction, Starting Text
     16 N I,IEN,CNT S CNT=44
     17 ;
     18 I DIR=0 D  ; Forward direction
     19 . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM)) Q:FROM=""  D
     20 . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM
     21 . I $G(Y(CNT))="" S Y(I)=""
     22 ;
     23 I DIR=1 D  ; Reverse direction
     24 . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM),-1) Q:FROM=""  D
     25 . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM
     26 Q
     27ODEF(Y,DLG) ; Return the definition for a dialog
     28 Q:'$L(DLG)
     29 S DLG=+$O(^ORD(101.41,"B",DLG,0))
     30 Q:$D(^ORD(101.41,DLG,50))<10
     31 N I,IEN,IDX
     32 S I=0,IDX=0
     33 S Y(0)=$P($G(^ORD(101.41,DLG,5)),"^",4)
     34 F  S I=$O(^ORD(101.41,DLG,50,"AC",I)) Q:I=""  S IEN=$O(^(I,0)) D
     35 . S IDX=IDX+1,Y(IDX)=$G(^ORD(101.41,DLG,50,IEN,0))
     36 Q
     37DEF(Y,DLG) ; Return format mapping for a dialog
     38 ; Y(n): CtrlName^DlgPtr^FmtSeq^Fmt^Omit^Lead^Trail^Mult?^chd1~chd2~...
     39 I DLG="NOT IMPLEMENTED" S Y(0)="0^0" Q                 ; for testing
     40 S DLG=$O(^ORD(101.41,"B",DLG,0))
     41 N I,J,K,N,X0,X2,XW,DPTR
     42 S Y(0)=$P(^ORD(101.41,DLG,0),U,5)_U_DLG
     43 S I=0,N=0
     44 F  S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0  D
     45 . S X0=$G(^ORD(101.41,DLG,10,I,0)),DPTR=$P(X0,U,2)
     46 . S X2=$G(^ORD(101.41,DLG,10,I,2))
     47 . S XW=$G(^ORD(101.41,DLG,10,I,"W"))
     48 . S N=N+1,Y(N)=$P(XW,U,1)_U_DPTR_U_X2,CHLD=""
     49 . S J=0 F  S J=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J)) Q:'J  D
     50 . . S K=0 F  S K=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J,K)) Q:'K  D
     51 . . . S CHLD=CHLD_$P(^ORD(101.41,DLG,10,K,0),U,2)_"~"
     52 . S $P(Y(N),U,8)=CHLD
     53 Q
     54FORMID(VAL,ORIFN)  ; procedure
     55 ; Returns the Dialog Form ID
     56 N X
     57 S VAL=0,X=$P(^OR(100,+ORIFN,0),U,5)
     58 Q:$P(X,";",2)'="ORD(101.41,"
     59 S VAL=+$P($G(^ORD(101.41,+X,5)),U,5)
     60 ; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2)
     61 Q
     62GET4EDIT(LST,ORIFN) ; procedure
     63 ; return responses in format that can be used by dialog
     64 N ILST,PRMT,INST,DLG,ORDIALOG S ILST=0
     65 I '$D(ORIFN) S LST=0 Q
     66 S ORIFN=+ORIFN,DLG=+$P(^OR(100,ORIFN,0),U,5)
     67 D GETDLG1^ORCD(DLG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)")
     68 S PRMT=0 F  S PRMT=$O(ORDIALOG(PRMT)) Q:'PRMT  D
     69 . S INST=0 F  S INST=$O(ORDIALOG(PRMT,INST)) Q:'INST  D
     70 . . S ILST=ILST+1,LST(ILST)="~"_PRMT_U_INST_U_$P(ORDIALOG(PRMT),U,3)
     71 . . S ILST=ILST+1,LST(ILST)="d"_ORDIALOG(PRMT,INST)
     72 . . I $E(ORDIALOG(PRMT,INST))=U D                 ; load word processing
     73 . . . N I,REF S I=0,REF=ORDIALOG(PRMT,INST)
     74 . . . F  S I=$O(@REF@(I)) Q:'I  S ILST=ILST+1,LST(ILST)="t"_^(I,0)
     75 . . E  S $P(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST)  ; load external value
     76 . . I "R"[$E(ORDIALOG(PRMT,0)) D
     77 . . . S $P(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST)))
     78 Q
     79EXTDT(X) ; Return an external date time that can be interpreted by %DT
     80 I $E(X)="T" Q "TODAY"_$E(X,2,255)
     81 I $E(X)="V" Q "NEXT VISIT"_$E(X,2,255)
     82 Q ""
     83WRLST(Y,TYP) ; Return list of dialogs for writing orders
     84 ; .Y(n): DlgName^ListBox Text
     85 ;   TYP: 'I' = inpatient, 'O' = outpatient
     86 N PAR,ERR,SEQ,IEN,I,X
     87 S PAR=$S(TYP="I":"ORW ADDORD INPT",1:"ORW ADDORD OUTPT")
     88 D GETLST^XPAR(.X,"ALL",PAR,"Q",.ERR) Q:ERR
     89 S I=0 F  S I=$O(X(I)) Q:'I  D
     90 . S SEQ=$P(X(I),U,1),IEN=$P(X(I),U,2)
     91 . S Y(SEQ)=$P(^ORD(101.41,IEN,0),U,1)_U_$P($G(^(5)),U,4)
     92 Q
     93SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) ; procedure
     94 ; Save order
     95 N ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA
     96 I $P(^ORD(101.41,+DLG,0),U)="PSO OERR" S ORCAT="O"
     97 I $P(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE" S ORCAT="I"
     98 S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2)
     99 D GETDLG^ORCD(DLG)
     100 M ORDIALOG=RSP S ORDIALOG=DLG
     101 I ORWDACT="N" D
     102 . D EN^ORCSAVE
     103 . S Y="" I ORIFN D GETBYIFN^ORWORR(.Y,ORIFN)
     104 I $P(ORWDACT,U,1)="E" D
     105 . S ORIFN=+$P(ORWDACT,U,2) D XX^ORCSAVE
     106 . S Y="" S ORIFN=+$P(ORWDACT,U,2)_";"_ORDA D GETBYIFN^ORWORR(.Y,ORIFN)
     107 Q
     108SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) ; procedure
     109 ; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR)
     110 N ORVP,ORL,IDX,ANERROR,ERRCNT
     111 S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2),ERRCNT=0
     112 I '$D(^XUSEC("ORES",DUZ)) S ERRLST(1)=0_U_"Must have ORES key." Q
     113 S IDX=0 F  S IDX=$O(ORWSIGN(IDX)) Q:'IDX  S X=ORWSIGN(IDX) D
     114 . ; ** change NATR when GUI changed to pass Nature in 4th piece
     115 . S ORIFN=$P(X,U),RELSTS=$P(X,U,2),SIGSTS=$P(X,U,3),NATR="E" ;$P(X,U,4)
     116 . I SIGSTS=2 D NOTIF^ORCSIGN S ANERROR=""
     117 . I SIGSTS'=2 D EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR)
     118 . I $L(ANERROR) D  Q           ; don't print if an error occurred
     119 . . S ERRCNT=ERRCNT+1,ERRLST(ERRCNT)=$P(ORWSIGN(IDX),U)_U_ANERROR
     120 . . K ORWSIGN(IDX)
     121 . I RELSTS=0 K ORWSIGN(IDX) Q  ; don't print if unreleased
     122 . S ORWSIGN(IDX)=$P(ORWSIGN(IDX),U)
     123 D PRINTS^ORWD1(.ORWSIGN,LOC)
     124 Q
     125VALIDACT(VAL,ORIFN,ACTION)      ;procedure
     126 ; Return 1 if action is valid for this order, otherwise 0^error
     127 S VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR)
     128 I VAL=0 S VAL=VAL_U_ERR
     129 Q
     130SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC)       ;procedure
     131 ; Save this action for the order (it is still unsigned/unreleased)
     132 N ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS
     133 S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC("
     134 S SIGSTS=2,RELSTS=11
     135 I '$P(ORIFN,";",2) S $P(ORIFN,";",2)=1
     136 I (ACTION="FL")!(ACTION="UF")!(ACTION="WC") S SIGSTS=3,RELSTS=""
     137 S ASTS=$P(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0),U,15)
     138 I ACTION="DC",((ASTS=10)!(ASTS=11)) D  Q       ; exit here if DELETE
     139 . D GETBYIFN^ORWORR(.LST,ORIFN)
     140 . S $P(LST(1),U,1)="~0",LST(2)="tDELETED - "_$E(LST(2),2,245)
     141 . D DELETE^ORCSAVE2(ORIFN)
     142 ;
     143 ; the only valid action for ActDA>1 is deletion, so only orders
     144 ; identified by ORIFN;1 should reach this point
     145 ;
     146 I $P(ORIFN,";",2)>1 S $ECODE=",Uorder action invalid," Q
     147 I ACTION="FL" S $P(^OR(100,+ORIFN,6),U,1)=1
     148 I ACTION="UF" S $P(^OR(100,+ORIFN,6),U,1)=0
     149 I ACTION'="RN" D
     150 . S ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON)
     151 I ACTION="RN" D
     152 . N ORDA,ORDIALOG,PRMT,SAVIFN,X0
     153 . S SAVIFN=+ORIFN,X0=^OR(100,+ORIFN,0)
     154 . I $P(X0,U,5)["101.41," D                        ; version 3
     155 . . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
     156 . . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
     157 . E  D                                            ; version 2.5 generic
     158 . . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
     159 . . D GETDLG^ORCD(ORDIALOG)
     160 . . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
     161 . . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
     162 . . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
     163 . . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
     164 . . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
     165 . D RN^ORCSAVE I 'ORIFN S $ECODE=",UCPRS renew order,"
     166 . S ACTDA=ORDA,ORIFN=SAVIFN
     167 I (ACTION="FL")!(ACTION="UF") S ACTDA=1
     168 D GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA)
     169 S $P(LST(1),U,12)=ACTDA
     170 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDAL32.m

    r613 r623  
    1 ORWDAL32        ; SLC/REV - Allergy calls to support windows ;5/31/05  14:14
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233,243**;Dec 17, 1997;Build 242
    3         ;
    4 DEF(LST)        ; Get dialog data for allergies
    5         N ILST,I,X S ILST=0
    6         S LST($$NXT)="~Allergy Types" D ALLGYTYP
    7         S LST($$NXT)="~Reactions" D ALLGYTYP
    8         S LST($$NXT)="~Nature of Reaction" D NATREACT
    9         S LST($$NXT)="~Top Ten" D TOPTEN
    10         S LST($$NXT)="~Observ/Hist" D OBSHIST
    11         S LST($$NXT)="~Severity" D SEVERITY
    12         Q
    13 GMRASITE(ORY)   ;Return GMRA Site Params
    14         N GMRASITE
    15         D SITE^GMRAUTL
    16         S ORY=$G(^GMRD(120.84,GMRASITE,0))
    17         Q
    18 TOPTEN  ;  Get top ten symptoms from Allergy Site Parameters file
    19         N X0,I,CNT,GMRASITE S I=0,X0="",CNT=0 ;233
    20         D SITE^GMRAUTL ;233
    21         F  S I=$O(^GMRD(120.84,GMRASITE,1,I)),CNT=CNT+1 Q:+I=0!(CNT>10)  D  ;233
    22         . S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0))  Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION"  ;233 Don't send this entry
    23         . ;233 Don't send if inactive term
    24         . I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",")
    25         . S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1)
    26         Q
    27 ALLSRCH(Y,X)    ; Return list of partial matches  ; CHANGED TO PRODUCE TREEVIEW IN GUI
    28         N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE=""
    29         S ORX=X,X=$$UP^XLFSTR(X)
    30         F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D
    31         . S ORSRC=$G(ORSRC)+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2)
    32         . I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+"
    33         . I ORSRC=1!(ORSRC=2) D
    34         .. I $D(@ROOT@(X)) D
    35         ... I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q  ;don't send this entry
    36         ... S ORIEN=$O(@ROOT@(X,0))
    37         ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q  ;233 Is term active?
    38         ... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
    39         ... I ORSRC'=2  S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT
    40         ... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
    41         .. S XP=X F  S XP=$O(@ROOT@(XP)) Q:XP=""  Q:$E(XP,1,$L(X))'=X  D
    42         ... I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q  ;don't send this entry
    43         ... S ORIEN=$O(@ROOT@(XP,0))
    44         ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q  ;233 Is term active?
    45         ... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches
    46         ... I ORSRC'=2  S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT
    47         ... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
    48         . I (ORSRC>2),(ORSRC'=4),(ORSRC'=5),(ORSRC'=6) D
    49         .. N CODE,LIST,VAL,NAME
    50         .. S CODE=$S(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"") Q:'$L(CODE)
    51         .. X CODE I $D(LIST) S ORIEN=0 F  S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN  D
    52         ... S NAME=$P(LIST(ORIEN),U,2)
    53         ... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
    54         ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",") Q
    55         ... S CNT=CNT+1,Y(CNT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC
    56         . I ORSRC=4 D
    57         .. N CODE,LIST,VAL,NAME
    58         .. S CODE="D TRDNAME(X,.LIST)"
    59         .. X CODE I $D(LIST) S ORIEN=0 F  S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN  D
    60         ... S NAME=$P(LIST(ORIEN),U,2)
    61         ... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
    62         ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",") Q
    63         ... S CNT=CNT+1,Y(CNT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC
    64         Q
    65 FILENAME        ; Display text of filenames for search treeview
    66         ;;VA Allergies File
    67         ;;VA Allergies File (Synonyms)  SPACER ONLY - NOT DISPLAYED
    68         ;;National Drug File - Generic Drug Name
    69         ;;National Drug file - Trade Name
    70         ;;Local Drug File
    71         ;;Local Drug File (Synonyms)  SPACER ONLY - NOT DISPLAYED
    72         ;;Drug Ingredients File
    73         ;;VA Drug Class File
    74         ;;
    75 NATREACT        ; Get the NATURE OF REACTION types
    76         ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file
    77         F X="A^Allergy","P^Pharmacological","U^Unknown" D
    78         . S LST($$NXT)="i"_X
    79         Q
    80 ALLGYTYP        ; Get the allergy types
    81         F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D
    82         . S LST($$NXT)="i"_X
    83         Q
    84 OBSHIST ; Observed or historical
    85         F X="o^Observed","h^Historical" D
    86         . S LST($$NXT)="i"_X
    87         Q
    88 SEVERITY        ; Severity
    89         F X="3^Severe","2^Moderate","1^Mild" D
    90         . S LST($$NXT)="i"_X
    91         Q
    92 SYMPTOMS(Y,FROM,DIR)    ; Return a subset of symptoms
    93         ; .Return Array, Starting Text, Direction
    94         N I,IEN,CNT,X,NAME,SUB S I=0,CNT=44 ;233
    95         K ^TMP($J,"SIGNS") ;233
    96         ;The following lines were added in 233.  Now accounts for synonyms
    97         M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233
    98         S SYN="" F  S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN=""  S SUB=0 F  S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB  D  ;233
    99         .S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233
    100         F  Q:I'<CNT  S FROM=$O(^TMP($J,"SIGNS","B",FROM),DIR) Q:FROM=""  D  ;233
    101         . I FROM="OTHER REACTION" Q  ;Don't send this entry
    102         . S IEN=0 F  S IEN=$O(^TMP($J,"SIGNS","B",FROM,IEN)) Q:'IEN  D  ;233
    103         . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.83,.01,IEN_",") Q  ;233 Is term active
    104         . . S I=I+1
    105         . . S Y(I)=IEN_U_FROM
    106         Q
    107 NXT()   ; Increment index of LST
    108         S ILST=ILST+1
    109         Q ILST
    110 EDITLOAD(Y,ORALIEN)     ; Load an allergy/adverse reaction for editing
    111         Q:+$G(ORALIEN)=0
    112         N ORNODE,I
    113         S ORNODE=$NAME(^TMP("GMRA",$J)),I=0
    114         ;following patch check is made via GUI RPC call to ORWU PATCH instead
    115         ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S @ORNODE@(0)="-1^Not yet implemented",Y=ORNODE Q
    116         D GETREC^GMRAGUI(ORALIEN,ORNODE)
    117         S Y=ORNODE
    118         Q
    119 EDITSAVE(ORY,ORALIEN,ORDFN,OREDITED)    ; Save Edit/Add of an allergy/adverse reaction
    120         ;following patch check is made via GUI RPC call to ORWU PATCH instead
    121         ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S Y="-1^Not yet implemented" Q
    122         N ORNODE
    123         S ORNODE=$NAME(^TMP("GMRA",$J))
    124         K @ORNODE M @ORNODE=OREDITED
    125         S ORY=0
    126         I $G(@ORNODE@("GMRAERR"))="YES" D EIE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q  ;Handle entered in error
    127         I $G(@ORNODE@("GMRANKA"))="YES" D NKA^GMRAGUI1 Q
    128         D UPDATE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q  ;Add/edit reactions
    129         Q
    130 SENDBULL(Y,ORDUZ,ORDFN,ORTEXT,ORCMTS)   ; Send bulletin if user attempts free-text entry
    131         I '$D(ORCMTS) D
    132         . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT)
    133         E  D
    134         . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT,.ORCMTS)
    135         Q
    136 INGSRCH(NAME,LIST)      ;
    137         K ^TMP($J,"ORWDAL32")
    138         D NAME^PSN50P41(NAME,"ORWDAL32")
    139         I $D(^TMP($J,"ORWDAL32","P")) D
    140         . N I S I="" F  S I=$O(^TMP($J,"ORWDAL32","P",I)) Q:I=""  D
    141         .. N J S J=0 F  S J=$O(^TMP($J,"ORWDAL32","P",I,J)) Q:'J  S LIST(J)=J_U_I
    142         K ^TMP($J,"ORWDAL32")
    143         Q
    144 CLASRCH(NAME,LIST)      ;
    145         K ^TMP($J,"ORWDAL32")
    146         D C^PSN50P65(,NAME,"ORWDAL32")
    147         I $D(^TMP($J,"ORWDAL32","C")) D
    148         . N I S I="" F  S I=$O(^TMP($J,"ORWDAL32","C",I)) Q:I=""  D
    149         .. N J S J=0 F  S J=$O(^TMP($J,"ORWDAL32","C",I,J)) Q:'J  S LIST(J)=J_U_$G(^TMP($J,"ORWDAL32",J,1))
    150         K ^TMP($J,"ORWDAL32")
    151         Q
    152 TRDNAME(NAME,LIST)      ;
    153         K ^TMP($J,"ORWDAL32")
    154         D ALL^PSN5067(,NAME,,"ORWDAL32")
    155         I $D(^TMP($J,"ORWDAL32","B")) D
    156         . N I S I="" F  S I=$O(^TMP($J,"ORWDAL32","B",I)) Q:I=""  D
    157         .. N J,K S J=$O(^TMP($J,"ORWDAL32","B",I,0)) Q:'J  S K=$$TGTOG^PSNAPIS(I),LIST(J)=K_U_$G(^TMP($J,"ORWDAL32",J,4))
    158         K ^TMP($J,"ORWDAL32")
    159         Q
     1ORWDAL32 ; SLC/REV - Allergy calls to support windows ;5/31/05  14:14
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233**;Dec 17, 1997
     3 ;
     4DEF(LST) ; Get dialog data for allergies
     5 N ILST,I,X S ILST=0
     6 S LST($$NXT)="~Allergy Types" D ALLGYTYP
     7 S LST($$NXT)="~Reactions" D ALLGYTYP
     8 S LST($$NXT)="~Nature of Reaction" D NATREACT
     9 S LST($$NXT)="~Top Ten" D TOPTEN
     10 S LST($$NXT)="~Observ/Hist" D OBSHIST
     11 S LST($$NXT)="~Severity" D SEVERITY
     12 Q
     13GMRASITE(ORY)   ;Return GMRA Site Params
     14 N GMRASITE
     15 D SITE^GMRAUTL
     16 S ORY=$G(^GMRD(120.84,GMRASITE,0))
     17 Q
     18TOPTEN ;  Get top ten symptoms from Allergy Site Parameters file
     19 N X0,I,CNT,GMRASITE S I=0,X0="",CNT=0 ;233
     20 D SITE^GMRAUTL ;233
     21 F  S I=$O(^GMRD(120.84,GMRASITE,1,I)),CNT=CNT+1 Q:+I=0!(CNT>10)  D  ;233
     22 . S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0))  Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION"  ;233 Don't send this entry
     23 . I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",")  ;233 Don't send if inactive term
     24 . S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1)
     25 Q
     26ALLSRCH(Y,X) ; Return list of partial matches  ; CHANGED TO PRODUCE TREEVIEW IN GUI
     27 N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE="",ORREAX=""
     28 S ORX=X,X=$$UP^XLFSTR(X)
     29 F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D
     30 . S ORSRC=ORSRC+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2)
     31 . I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+"
     32 . I $D(@ROOT@(X)) D
     33 . . I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q  ;don't send this entry
     34 . . I ORSRC=5!(ORSRC=6) Q  ;233 don't send file 50 entries
     35 . . S ORIEN=$O(@ROOT@(X,0))
     36 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=1!(ORSRC=2):120.82,ORSRC=3!(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,$S(ORSRC=4:$$TGTOG^PSNAPIS(X)_",",1:ORIEN_",")) Q  ;233 Is term active?
     37 . . I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
     38 . . E  I ORSRC=6 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^PSDRUG(+ORIEN,0)),U,1)_" <"_X_">"_ROOT
     39 . . E  S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT
     40 . . S ORREAX=$S($P(Y(CNT),U,3)?1"GMR".E:$P($G(^GMRD(120.82,+Y(CNT),0)),U,2),1:"D")
     41 . . S Y(CNT)=Y(CNT)_U_ORREAX_U_$S(ORSRC=2:1,ORSRC=6:5,1:ORSRC)
     42 . S XP=X F  S XP=$O(@ROOT@(XP)) Q:XP=""  Q:$E(XP,1,$L(X))'=X  D
     43 . . I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q  ;don't send this entry
     44 . . I ORSRC=5!(ORSRC=6) Q  ;233 Don't send file 50 entries
     45 . . S ORIEN=$O(@ROOT@(XP,0))
     46 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=1!(ORSRC=2):120.82,ORSRC=3!(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,$S(ORSRC=4:$$TGTOG^PSNAPIS(XP)_",",1:ORIEN_",")) Q  ;233 Is term active?
     47 . . I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches
     48 . . E  I ORSRC=6 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^PSDRUG(+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches
     49 . . E  S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT
     50 . . S ORREAX=$S($P(Y(CNT),U,3)?1"GMR".E:$P($G(^GMRD(120.82,+Y(CNT),0)),U,2),1:"D")
     51 . . S Y(CNT)=Y(CNT)_U_ORREAX_U_$S(ORSRC=2:1,ORSRC=6:5,1:ORSRC)
     52 Q
     53FILENAME        ; Display text of filenames for search treeview
     54 ;;VA Allergies File
     55 ;;VA Allergies File (Synonyms)  SPACER ONLY - NOT DISPLAYED
     56 ;;National Drug File - Generic Drug Name
     57 ;;National Drug file - Trade Name
     58 ;;Local Drug File
     59 ;;Local Drug File (Synonyms)  SPACER ONLY - NOT DISPLAYED
     60 ;;Drug Ingredients File
     61 ;;VA Drug Class File
     62 ;;
     63NATREACT ; Get the NATURE OF REACTION types
     64 ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file
     65 F X="A^Allergy","P^Pharmacological","U^Unknown" D
     66 . S LST($$NXT)="i"_X
     67 Q
     68ALLGYTYP ; Get the allergy types
     69 F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D
     70 . S LST($$NXT)="i"_X
     71 Q
     72OBSHIST ; Observed or historical
     73 F X="o^Observed","h^Historical" D
     74 . S LST($$NXT)="i"_X
     75 Q
     76SEVERITY ; Severity
     77 F X="3^Severe","2^Moderate","1^Mild" D
     78 . S LST($$NXT)="i"_X
     79 Q
     80SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms
     81 ; .Return Array, Starting Text, Direction
     82 N I,IEN,CNT,X,NAME,SUB S I=0,CNT=44 ;233
     83 K ^TMP($J,"SIGNS") ;233
     84 ;The following lines were added in 233.  Now accounts for synonyms
     85 M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233
     86 S SYN="" F  S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN=""  S SUB=0 F  S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB  D  ;233
     87 .S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233
     88 F  Q:I'<CNT  S FROM=$O(^TMP($J,"SIGNS","B",FROM),DIR) Q:FROM=""  D  ;233
     89 . I FROM="OTHER REACTION" Q  ;Don't send this entry
     90 . S IEN=0 F  S IEN=$O(^TMP($J,"SIGNS","B",FROM,IEN)) Q:'IEN  D  ;233
     91 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.83,.01,IEN_",") Q  ;233 Is term active
     92 . . S I=I+1
     93 . . S Y(I)=IEN_U_FROM
     94 Q
     95NXT() ; Increment index of LST
     96 S ILST=ILST+1
     97 Q ILST
     98EDITLOAD(Y,ORALIEN)     ; Load an allergy/adverse reaction for editing
     99 Q:+$G(ORALIEN)=0
     100 N ORNODE,I
     101 S ORNODE=$NAME(^TMP("GMRA",$J)),I=0
     102 ;following patch check is made via GUI RPC call to ORWU PATCH instead
     103 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S @ORNODE@(0)="-1^Not yet implemented",Y=ORNODE Q
     104 D GETREC^GMRAGUI(ORALIEN,ORNODE)
     105 S Y=ORNODE
     106 Q
     107EDITSAVE(ORY,ORALIEN,ORDFN,OREDITED)      ; Save Edit/Add of an allergy/adverse reaction
     108 ;following patch check is made via GUI RPC call to ORWU PATCH instead
     109 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S Y="-1^Not yet implemented" Q
     110 N ORNODE
     111 S ORNODE=$NAME(^TMP("GMRA",$J))
     112 K @ORNODE M @ORNODE=OREDITED
     113 S ORY=0
     114 I $G(@ORNODE@("GMRAERR"))="YES" D EIE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q  ;Handle entered in error
     115 I $G(@ORNODE@("GMRANKA"))="YES" D NKA^GMRAGUI1 Q
     116 D UPDATE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q  ;Add/edit reactions
     117 Q
     118SENDBULL(Y,ORDUZ,ORDFN,ORTEXT,ORCMTS)      ; Send bulletin if user attempts free-text entry
     119 I '$D(ORCMTS) D
     120 . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT)
     121 E  D
     122 . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT,.ORCMTS)
     123 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA1.m

    r613 r623  
    1 ORWDBA1 ;; SLC OIFO/DKK/GSS - Order Dialogs Billing Awareness;[10/21/03 3:16pm]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,229,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; External References
    5         ;   DBIA    406  CL^SDCO21 - call to determine Treatment Factors
    6         ;
    7         ;Ref to ^DIC(9.4 - DBIA ___
    8         ;BA refers to Billing Awareness Project
    9         ;CIDC refers to Clinical Indicator Data Capture (same project 3/10/2004)
    10         ;Treatment Factors (TxF) refer to SC,AO,IR,EC,MST,HNC,CV,SHD
    11         ;
    12 GETORDX(Y,ORIEN)        ; Retrieve Diagnoses for an order - RPC
    13         ; Input:
    14         ;   ORIEN    Order Internal ID#
    15         ; Output:
    16         ;   Y        Array of Diagnoses (Dx) - Y(#)=#^DxInt#^ICD9^DxDesc^TxF
    17         ; Variables used:
    18         ;   CT       Counter for # of Dx related to order
    19         ;   DXIEN    Dx internal ID
    20         ;   DXN      Internal (to ^OR(100)) sequence # for Dx storage
    21         ;   DXREC    Dx record from Order file
    22         ;   DXV      Dx description
    23         ;   ICD9     External ICD9 #
    24         ;   TXFACTRS Treatment Factors (TxF)
    25         ;
    26         N CT,DXIEN,DXN,DXREC,DXV,ICD9,ICDR,ORFMDAT,TXFACTRS
    27         S (CT,DXN)=0
    28         I '$G(^OR(100,ORIEN,0)) S Y=-1
    29         I '$D(^OR(100,ORIEN,5.1,1,0)) S Y=0
    30         E  D  S Y=CT
    31         . ; Get order date for CSV/CTD/HIPAA usage
    32         . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN)
    33         . ; Go through all Dx's for an order
    34         . F  S DXN=$O(^OR(100,ORIEN,5.1,DXN)) Q:DXN'?1N.N  D
    35         .. ; Get diagnosis record and IEN
    36         .. S DXREC=$G(^OR(100,ORIEN,5.1,DXN,0)),DXIEN=$P(DXREC,U)
    37         .. S ICDR=$$ICDDX^ICDCODE($G(DXIEN),ORFMDAT)
    38         .. S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2)
    39         .. ; Convert internal to external Treatment Factors
    40         .. S TXFACTRS=$$TFGBLGUI(^OR(100,ORIEN,5.2))
    41         .. S CT=CT+1,Y(CT)=DXN_U_$G(DXIEN)_U_ICD9_U_DXV_U_TXFACTRS
    42         Q
    43         ;
    44 SCLST(Y,DFN,ORLST)      ; RPC for compiling appropriate TxF's
    45         ; RPC titled ORWDBA1 SCLST
    46         ;
    47         ;  Y       =    Returned value
    48         ;  DFN     =    Patient IEN
    49         ;  ORLST   =    List of orders
    50         ;
    51         ; call for BA/TF
    52         N GMRCPROS,ORD,ORI,ORPKG
    53         D CPLSTBA(.Y,DFN,.ORLST)
    54         Q
    55         ;
    56 CPLSTBA(TEST,PTIFN,ORIFNS)      ; set-up SC/TFs for BA
    57         ;
    58         ;  TEST    =  Returned value
    59         ;  PTIFN   =  Patient IEN
    60         ;  ORIFNS  =  List of orders
    61         ;
    62         S ORI=""
    63         ;
    64         ; define array of packages for which BA data collected (SC/CIs)
    65         ;  GMRC    =  Consult/Request Tracking (#128) - Prosthetics
    66         ;  LR      =  Lab Services (#26) - Lab
    67         ;  PSO     =  Outpt Pharmacy (#112) - Outpt Pharmacy (orig. Co-Pay)
    68         ;  RA      =  Radiology/Nuclear Medicine (#31) - Radiology
    69         ;
    70         S ORPKG(+$O(^DIC(9.4,"C","PSO",0)))=1
    71         ; See ISWITCH^ORWDBA7 for insurance/Ed switch, i.e., $$CIDC^IBBAPI
    72         ; Also check provider switch via 'OR BILLING AWARENESS BY USER'
    73         I $$BASTAT&$$CIDC^IBBAPI(DFN)&$$GET^XPAR(DUZ_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q") F I=1:1 S ORPKG=$P("GMRC;LR;RA",";",I) Q:ORPKG=""  D
    74         . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=1  ; ^DIC(9.4) is package file
    75         ;
    76         ; get Treatment Factors (TxF) for patient
    77         D SCPRE(.DR,DFN)
    78         ;
    79         ; set TxF's if order is for a package for which BA data is collected
    80         F  S ORI=$O(ORLST(ORI)) Q:'ORI  S ORD=+ORLST(ORI) D
    81         . I $G(^OR(100,ORD,0))="" Q
    82         . I $P($G(^OR(100,ORD,0)),U,14)="" Q
    83         . I $D(TEST(ORD))!'$D(ORPKG($P($G(^OR(100,ORD,0)),U,14))) Q
    84         . I $E($P(ORIFNS(ORI),";",2))>1 Q  ;canceled order (2) & ? (3)
    85         . S TEST(ORD)=ORLST(ORI)_DR
    86         Q
    87         ;
    88 SCPRE(DR,DFN)   ; Dialog validation, to ask BA questions
    89         ;
    90         ;  DR    =  return value
    91         ;  DFN   =  input patient IEN
    92         ;
    93         Q:$G(DFN)=""
    94         N CPNODE,CT,I,ORX,ORSDCARY,TF,X
    95         K ORSDCARY
    96         S (CPNODE,DR,ORX,TF)="",CT=0,X="T"
    97         ; Call API to acquire Treatment Factors in force
    98         D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY)  ;DBIA 406
    99         ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV,SHD e.g., ORSDCARY(3) for SC
    100         ; Convert to ^OR/CPRS GUI order: SC,MST,AO,IR,EC,HNC,CV,SHD
    101         F I=3,5,1,2,4,6,7,8 S TF=0,CT=CT+1 S:$D(ORSDCARY(I)) TF=1 S $P(CPNODE,U,CT)=TF
    102         ;
    103         S X=$S($P(CPNODE,U)=1:"SC",1:""),DR=$S($L(X):DR_U_X,1:DR)
    104         S X=$S($P(CPNODE,U,2)=1:"MST",1:""),DR=$S($L(X):DR_U_X,1:DR)
    105         S X=$S($P(CPNODE,U,3)=1:"AO",1:""),DR=$S($L(X):DR_U_X,1:DR)
    106         S X=$S($P(CPNODE,U,4)=1:"IR",1:""),DR=$S($L(X):DR_U_X,1:DR)
    107         S X=$S($P(CPNODE,U,5)=1:"EC",1:""),DR=$S($L(X):DR_U_X,1:DR)
    108         S X=$S($P(CPNODE,U,6)=1:"HNC",1:""),DR=$S($L(X):DR_U_X,1:DR)
    109         S X=$S($P(CPNODE,U,7)=1:"CV",1:""),DR=$S($L(X):DR_U_X,1:DR)
    110         S X=$S($P(CPNODE,U,8)=1:"SHD",1:""),DR=$S($L(X):DR_U_X,1:DR)
    111         ;
    112         ; TxF's for patient (TxF's include SC,AO,IR,EC,MST,HNC,CV,SHD) where
    113         ;  SC      =  Service Connected
    114         ;  AO      =  Agent Orange
    115         ;  IR      =  Ionizing Radiation
    116         ;  EC      =  Environmental Contaminants
    117         ;  MST     =  Military Sexual Trauma
    118         ;  HNC     =  Head and Neck Cancer
    119         ;  CV      =  Combat Veteran
    120         ;  SHD     =  Shipboard Disability
    121         F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D
    122         . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"")
    123         Q
    124         ;
    125 ORPKGTYP(Y,ORLST)       ; Build BA supported packages array
    126         ; GMRC=Prosthetics, LR=Lab, PSO=Pharmacy, RA=Radiology
    127         N OIREC,OIV,OIVN
    128         ;
    129         F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG=""  D
    130         . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=ORPKG  ; ^DIC(9.4) is package file
    131         ;
    132         S GMRCPROS=+$O(^DIC(9.4,"C","GMRC",0))
    133         ; see if order is for a package which BA supports
    134         D ORPKG1(.Y,.ORLST)
    135         Q
    136         ;
    137 ORPKG1(TEST,ORIFNS)     ; Order for package BA supports?  TEST(ORI)=1 is YES
    138         S U="^",ORI=""
    139         F I=1:1:5 S OIV(I)=$P("PROSTHETICS REQUEST^EYEGLASS REQUEST^CONTACT LENS REQUEST^HOME OXYGEN REQUEST^AMPUTEE/PROSTHETICS CLINIC",U,I)
    140         F  S ORI=$O(ORIFNS(ORI)) Q:'ORI  S ORD=+ORIFNS(ORI),TEST(ORI)=0 D
    141         . I ORD=0 Q  ;document/note not an order
    142         . ;I ORD="CONSULT_DX" S TEST(ORI)=1 Q  ;consult dx prev entered
    143         . I '$D(^OR(100,ORD,0)) Q  ;invalid order #
    144         . I $P(^OR(100,ORD,0),U,14)'?1N.N Q  ;invalid order # or entry
    145         . I $E($P(ORIFNS(ORI),";",2))>1 Q  ;canceled order (2) & ? (3)
    146         . I $D(^OR(100,ORD,5.1,1,0)) S TEST(ORI)=1 Q  ;
    147         . I '$D(ORPKG($P(^OR(100,ORD,0),U,14))) Q  ;pkg not supported
    148         . ;      IPt OPt (ask BA questions?)
    149         . ; Pros  Y   Y   GMRC
    150         . ; Rad   Y   Y   RA
    151         . ; Lab   N   Y   LR
    152         . ; Phrm  Y   Y   PSO
    153         . ; Pt Class = 'I' or 'O' in ^OR
    154         . I $P(^OR(100,ORD,0),U,12)="I"&(ORPKG($P(^OR(100,ORD,0),U,14))="LR") Q
    155         . I $P(^OR(100,ORD,0),U,14)=GMRCPROS D  Q  ;check for Pros consult order
    156         .. S OIREC=$G(^ORD(101.43,$G(^OR(100,ORD,4.5,1,1)),0)),OIVN=""
    157         .. F  S OIVN=$O(OIV(OIVN)) Q:OIVN=""  I OIV(OIVN)=$E($P(OIREC,U),1,$L(OIV(OIVN))) S TEST(ORI)=1 Q
    158         . S TEST(ORI)=1  ;order is for a supported pkg (also note Pros ck above)
    159         Q
    160         ;
    161 BASTATUS(Y)     ;RPC to retrieve the status of the Billing Awareness software
    162         ;   Y  =  Returned Value (1=BA usable, 0=BA not-usable)
    163         ; Check for installation of CIDC ancillary build
    164         S Y=$D(^XPD(9.7,"B","PX CLINICAL INDICATOR DATA CAPTURE 1.0"))
    165         Q:'Y
    166         ; Check if system parameter switch set
    167         S Y=$$CHKPS1^ORWDBA5
    168         Q
    169         ;
    170 BASTAT()        ; Internal version of BASTATUS
    171         ; Returns 0 if disabled or 1 if enabled
    172         Q $$CHKPS1^ORWDBA5
    173         ;
    174 RCVORCI(Y,DIAG) ;Receive order related Clinical Indicators & Diagnoses from GUI
    175         ; Store data in ^OR(100,ODN,5.1) & ^OR(100,0DN,5.2)
    176         ;
    177         N DXIEN,ODN,ORIEN,SCI,OCDXCT,OCT
    178         S ODN="",OCDXCT=0,Y=""
    179         F  S ODN=$O(DIAG(ODN)) Q:ODN=""  D
    180         . S ORIEN=$P(DIAG(ODN),";",1)  ;Order IEN
    181         . I ORIEN'?1N.N S Y=0 Q
    182         . K ^OR(100,ORIEN,5.1) ;Clear currently stored diagnosis for rewrite
    183         . ; Data from Delphi format: ORIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4
    184         . ; Convert 8 Tx Factors
    185         . S SCI=$$TFGUIGBL($RE($E($RE($P(DIAG(ODN),U)),1,8)))
    186         . S ^OR(100,ORIEN,5.2)=SCI  ;Store TFs (SC,MST,AO,IR,EC,HNC,CV,SHD)
    187         . ; Get order date for CSV/CTD/HIPAA
    188         . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN)
    189         . ; Go through the diagnoses entered
    190         . F OCT=2:1 Q:$P(DIAG(ODN),U,OCT)=""  D
    191         .. S DXIEN=$P($$ICDDX^ICDCODE($P(DIAG(ODN),U,OCT),ORFMDAT),U,1)  ;Dx IEN
    192         .. I DXIEN=-1!(DXIEN="") Q  ;No or invalid code passed in
    193         .. S OCDXCT=OCDXCT+1
    194         .. S ^OR(100,ORIEN,5.1,0)="^100.051PA^"_OCDXCT_U_OCDXCT ;Set 5.1 zero node
    195         .. S ^OR(100,ORIEN,5.1,OCDXCT,0)=DXIEN  ;Store a diagnosis for order
    196         .. S ^OR(100,ORIEN,5.1,"B",DXIEN,OCDXCT)="" ;Index diagnosis for order
    197         S:Y="" Y=1
    198         Q
    199         ;
    200 TFSTGS  ; Set Treatment Factor strings sequence order
    201         ; TFGBL is order of TxFs in ^OR(100,ORIEN,5) & ^OR(100,ORIEN,5.2)
    202         ; TFGUI is order of TxFs to/from GUI
    203         ; TFTBL is order of TxFs for table SD008 (used in ZCL segment)
    204         ; NOTE: change examples in TFGUIGBL and TFGBLGUI if order changed
    205         S TFGBL="SC^MST^AO^IR^EC^HNC^CV^SHD"
    206         S TFGUI="SC^AO^IR^EC^MST^HNC^CV^SHD"
    207         S TFTBL="AO^IR^SC^EC^MST^HNC^CV^SHD"
    208         Q
    209         ;
    210 TFGUIGBL(GUI)   ;Convert Treatment Factors from GUI to Global order & format
    211         ;
    212         ; Input:  GUI in CNU?NCU: C=checked, N=not checked, U=unchecked
    213         ; Output: GBL in 1^^^0^?^1^0^ (global) format (reordered for storage)
    214         ;
    215         N GBL,J,NTF,TF,TFGBL,TFGUI,TFTBL
    216         S GBL="",NTF=8  ;NTF=# of Treatment Factors (TxF)
    217         ;I $L(GUI)'=NTF Q -1  ;invalid # of TxF
    218         ; Get Treatment Factor sequence order strings
    219         D TFSTGS
    220         ; Convert from GBL to GUI format and sequence
    221         F J=1:1:NTF S TF=$E(GUI,J) D
    222         . S TF($P(TFGUI,U,J))=$S(TF="C":1,TF="U":0,TF="?":"?",1:"")
    223         F J=1:1:NTF S GBL=GBL_U_TF($P(TFGBL,U,J))
    224         Q $P(GBL,U,2,NTF+1)
    225         ;
    226 TFGBLGUI(GBL)   ;Convert Treatment Factors from Global to GUI order & format
    227         ;
    228         ; Input:  GBL in 1^0^1^1^^0^?^ (global) format
    229         ; Output: GUI in CCCNUU? (GUI) format (also reordered)
    230         ;
    231         N GUI,J,NTF,TF,TFGBL,TFGUI,TFTBL
    232         S GUI="",NTF=8  ;NCI=# of TxF
    233         ; Get Treatment Factor sequence order strings
    234         D TFSTGS
    235         ; Convert from GUI to GBL format and sequence
    236         F J=1:1:NTF S TF=$P(GBL,U,J) D
    237         . S TF($P(TFGBL,U,J))=$S(TF=1:"C",TF=0:"U",TF="?":"?",1:"N")
    238         F J=1:1:NTF S GUI=GUI_TF($P(TFGUI,U,J))
    239         Q GUI
    240         ;
    241 PRVKEY(X)       ;Check for active & provider key - to be deleted in CPRS v26
    242         N PTD
    243         Q:'+$G(X) 0
    244         Q:$G(^VA(200,X,0))="" 0
    245         S PTD=+$P(^VA(200,X,0),"^",11)
    246         I $$DT^XLFDT'<PTD,PTD>0 Q 0
    247         Q:$D(^XUSEC("PROVIDER",X)) 1
    248         Q 0
    249         ;
    250 ORESKEY(X)      ;Does 'X' hold ORES key, returns: 1=true, 0=false
    251         Q:'+$G(X) 0
    252         Q:$D(^XUSEC("ORES",X)) 1
    253         Q 0
     1ORWDBA1 ;; SLC OIFO/DKK/GSS - Order Dialogs Billing Awareness;[10/21/03 3:16pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,229,215**;Dec 17, 1997
     3 ;
     4 ; External References
     5 ;   DBIA    406  CL^SDCO21 - call to determine Treatment Factors
     6 ;
     7 ;Ref to ^DIC(9.4 - DBIA ___
     8 ;BA refers to Billing Awareness Project
     9 ;CIDC refers to Clinical Indicator Data Capture (same project 3/10/2004)
     10 ;Treatment Factors (TxF) refer to SC,AO,IR,EC,MST,HNC,CV
     11 ;
     12GETORDX(Y,ORIEN) ; Retrieve Diagnoses for an order - RPC
     13 ; Input:
     14 ;   ORIEN    Order Internal ID#
     15 ; Output:
     16 ;   Y        Array of Diagnoses (Dx) - Y(#)=#^DxInt#^ICD9^DxDesc^TxF
     17 ; Variables used:
     18 ;   CT       Counter for # of Dx related to order
     19 ;   DXIEN    Dx internal ID
     20 ;   DXN      Internal (to ^OR(100)) sequence # for Dx storage
     21 ;   DXREC    Dx record from Order file
     22 ;   DXV      Dx description
     23 ;   ICD9     External ICD9 #
     24 ;   TXFACTRS Treatment Factors (TxF)
     25 ;
     26 N CT,DXIEN,DXN,DXREC,DXV,ICD9,ICDR,ORFMDAT,TXFACTRS
     27 S (CT,DXN)=0
     28 I '$G(^OR(100,ORIEN,0)) S Y=-1
     29 I '$D(^OR(100,ORIEN,5.1,1,0)) S Y=0
     30 E  D  S Y=CT
     31 . ; Get order date for CSV/CTD/HIPAA usage
     32 . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN)
     33 . ; Go through all Dx's for an order
     34 . F  S DXN=$O(^OR(100,ORIEN,5.1,DXN)) Q:DXN'?1N.N  D
     35 .. ; Get diagnosis record and IEN
     36 .. S DXREC=$G(^OR(100,ORIEN,5.1,DXN,0)),DXIEN=$P(DXREC,U)
     37 .. S ICDR=$$ICDDX^ICDCODE($G(DXIEN),ORFMDAT)
     38 .. S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2)
     39 .. ; Convert internal to external Treatment Factors
     40 .. S TXFACTRS=$$TFGBLGUI(^OR(100,ORIEN,5.2))
     41 .. S CT=CT+1,Y(CT)=DXN_U_$G(DXIEN)_U_ICD9_U_DXV_U_TXFACTRS
     42 Q
     43 ;
     44SCLST(Y,DFN,ORLST) ; RPC for compiling appropriate TxF's
     45 ; RPC titled ORWDBA1 SCLST
     46 ;
     47 ;  Y       =    Returned value
     48 ;  DFN     =    Patient IEN
     49 ;  ORLST   =    List of orders
     50 ;
     51 ; call for BA/TF
     52 N GMRCPROS,ORD,ORI,ORPKG
     53 D CPLSTBA(.Y,DFN,.ORLST)
     54 Q
     55 ;
     56CPLSTBA(TEST,PTIFN,ORIFNS) ; set-up SC/TFs for BA
     57 ;
     58 ;  TEST    =  Returned value
     59 ;  PTIFN   =  Patient IEN
     60 ;  ORIFNS  =  List of orders
     61 ;
     62 S ORI=""
     63 ;
     64 ; define array of packages for which BA data collected (SC/CIs)
     65 ;  GMRC    =  Consult/Request Tracking (#128) - Prosthetics
     66 ;  LR      =  Lab Services (#26) - Lab
     67 ;  PSO     =  Outpt Pharmacy (#112) - Outpt Pharmacy (orig. Co-Pay)
     68 ;  RA      =  Radiology/Nuclear Medicine (#31) - Radiology
     69 ;
     70 F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG=""  D
     71 . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=1  ; ^DIC(9.4) is package file
     72 ;
     73 ; get Treatment Factors (TxF) for patient
     74 D SCPRE(.DR,DFN)
     75 ;
     76 ; set TxF's if order is for a package for which BA data is collected
     77 F  S ORI=$O(ORLST(ORI)) Q:'ORI  S ORD=+ORLST(ORI) D
     78 . I $G(^OR(100,ORD,0))="" Q
     79 . I $D(TEST(ORD))!'$D(ORPKG($P($G(^OR(100,ORD,0)),U,14))) Q
     80 . S TEST(ORD)=ORLST(ORI)_DR
     81 Q
     82 ;
     83SCPRE(DR,DFN) ; Dialog validation, to ask BA questions
     84 ;
     85 ;  DR    =  return value
     86 ;  DFN   =  input patient IEN
     87 ;
     88 Q:$G(DFN)=""
     89 N CPNODE,CT,I,ORX,ORSDCARY,TF,X
     90 K ORSDCARY
     91 S (CPNODE,DR,ORX,TF)="",CT=0,X="T"
     92 ; Call API to acquire Treatment Factors in force
     93 D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY)  ;DBIA 406
     94 ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV, e.g., ORSDCARY(3) for SC
     95 ; Convert to ^OR/CPRS GUI order: SC,MST,AO,IR,EC,HNC,CV
     96 F I=3,5,1,2,4,6,7 S TF=0,CT=CT+1 S:$D(ORSDCARY(I)) TF=1 S $P(CPNODE,U,CT)=TF
     97 ;
     98 S X=$S($P(CPNODE,U)=1:"SC",1:""),DR=$S($L(X):DR_U_X,1:DR)
     99 S X=$S($P(CPNODE,U,2)=1:"MST",1:""),DR=$S($L(X):DR_U_X,1:DR)
     100 S X=$S($P(CPNODE,U,3)=1:"AO",1:""),DR=$S($L(X):DR_U_X,1:DR)
     101 S X=$S($P(CPNODE,U,4)=1:"IR",1:""),DR=$S($L(X):DR_U_X,1:DR)
     102 S X=$S($P(CPNODE,U,5)=1:"EC",1:""),DR=$S($L(X):DR_U_X,1:DR)
     103 S X=$S($P(CPNODE,U,6)=1:"HNC",1:""),DR=$S($L(X):DR_U_X,1:DR)
     104 S X=$S($P(CPNODE,U,7)=1:"CV",1:""),DR=$S($L(X):DR_U_X,1:DR)
     105 ;
     106 ; TxF's for patient (TxF's include SC,AO,IR,EC,MST,HNC,CV) where
     107 ;  SC      =  Service Connected
     108 ;  AO      =  Agent Orange
     109 ;  IR      =  Ionizing Radiation
     110 ;  EC      =  Environmental Contaminants
     111 ;  MST     =  Military Sexual Trauma
     112 ;  HNC     =  Head and Neck Cancer
     113 ;  CV      =  Combat Veteran
     114 F I="SC","AO","IR","EC","MST","HNC","CV" D
     115 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"")
     116 Q
     117 ;
     118ORPKGTYP(Y,ORLST) ; Build BA supported packages array
     119 ; GMRC=Prosthetics, LR=Lab, PSO=Pharmacy, RA=Radiology
     120 N OIREC,OIV,OIVN
     121 F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG=""  D
     122 . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=ORPKG  ; ^DIC(9.4) is package file
     123 S GMRCPROS=+$O(^DIC(9.4,"C","GMRC",0))
     124 ; see if order is for a package which BA supports
     125 D ORPKG1(.Y,.ORLST)
     126 Q
     127 ;
     128ORPKG1(TEST,ORIFNS) ; Order for package BA supports?  TEST(ORI)=1 is YES
     129 S U="^",ORI=""
     130 F I=1:1:5 S OIV(I)=$P("PROSTHETICS REQUEST^EYEGLASS REQUEST^CONTACT LENS REQUEST^HOME OXYGEN REQUEST^AMPUTEE/PROSTHETICS CLINIC",U,I)
     131 F  S ORI=$O(ORIFNS(ORI)) Q:'ORI  S ORD=+ORIFNS(ORI),TEST(ORI)=0 D
     132 . I ORD=0 Q  ;document/note not an order
     133 . ;I ORD="CONSULT_DX" S TEST(ORI)=1 Q  ;consult dx prev entered
     134 . I '$D(^OR(100,ORD,0)) Q  ;invalid order #
     135 . I $P(^OR(100,ORD,0),U,14)'?1N.N Q  ;invalid order # or entry
     136 . I $E($P(ORIFNS(ORI),";",2))>1 Q  ;canceled order (2) & ? (3)
     137 . I $D(^OR(100,ORD,5.1,1,0)) S TEST(ORI)=1 Q  ;
     138 . I '$D(ORPKG($P(^OR(100,ORD,0),U,14))) Q  ;pkg not supported
     139 . ;      IPt OPt (ask BA questions?)
     140 . ; Pros  Y   Y   GMRC
     141 . ; Rad   Y   Y   RA
     142 . ; Lab   N   Y   LR
     143 . ; Phrm  Y   Y   PSO
     144 . ; Pt Class = 'I' or 'O' in ^OR
     145 . I $P(^OR(100,ORD,0),U,12)="I"&(ORPKG($P(^OR(100,ORD,0),U,14))="LR") Q
     146 . I $P(^OR(100,ORD,0),U,14)=GMRCPROS D  Q  ;check for Pros consult order
     147 .. S OIREC=$G(^ORD(101.43,$G(^OR(100,ORD,4.5,1,1)),0)),OIVN=""
     148 .. F  S OIVN=$O(OIV(OIVN)) Q:OIVN=""  I OIV(OIVN)=$E($P(OIREC,U),1,$L(OIV(OIVN))) S TEST(ORI)=1 Q
     149 . S TEST(ORI)=1  ;order is for a supported pkg (also note Pros ck above)
     150 Q
     151 ;
     152BASTATUS(Y) ;RPC to retrieve the status of the Billing Awareness software
     153 ;   Y  =  Returned Value (1=BA usable, 0=BA not-usable)
     154 ; Check for installation of CIDC ancillary build
     155 S Y=$D(^XPD(9.7,"B","PX CLINICAL INDICATOR DATA CAPTURE 1.0"))
     156 Q:'Y
     157 ; Check if system parameter switch set
     158 S Y=$$CHKPS1^ORWDBA5
     159 Q
     160 ;
     161BASTAT() ; Internal version of BASTATUS
     162 ; Returns 0 if disabled or 1 if enabled
     163 Q $$CHKPS1^ORWDBA5
     164 ;
     165RCVORCI(Y,DIAG) ;Receive order related Clinical Indicators & Diagnoses from GUI
     166 ; Store data in ^OR(100,ODN,5.1) & ^OR(100,0DN,5.2)
     167 ;
     168 N DXIEN,ODN,ORIEN,SCI,OCDXCT,OCT
     169 S ODN="",OCDXCT=0,Y=""
     170 F  S ODN=$O(DIAG(ODN)) Q:ODN=""  D
     171 . S ORIEN=$P(DIAG(ODN),";",1)  ;Order IEN
     172 . I ORIEN'?1N.N S Y=0 Q
     173 . K ^OR(100,ORIEN,5.1) ;Clear currently stored diagnosis for rewrite
     174 . ; Data from Delphi format: ORIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4
     175 . ; Convert 7 Tx Factors
     176 . S SCI=$$TFGUIGBL($RE($E($RE($P(DIAG(ODN),U)),1,7)))
     177 . S ^OR(100,ORIEN,5.2)=SCI  ;Store TFs (SC,MST,AO,IR,EC..)
     178 . ; Get order date for CSV/CTD/HIPAA
     179 . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN)
     180 . ; Go through the diagnoses entered
     181 . F OCT=2:1 Q:$P(DIAG(ODN),U,OCT)=""  D
     182 .. S DXIEN=$P($$ICDDX^ICDCODE($P(DIAG(ODN),U,OCT),ORFMDAT),U,1)  ;Dx IEN
     183 .. I DXIEN=-1!(DXIEN="") Q  ;No or invalid code passed in
     184 .. S OCDXCT=OCDXCT+1
     185 .. S ^OR(100,ORIEN,5.1,0)="^100.051PA^"_OCDXCT_U_OCDXCT ;Set 5.1 zero node
     186 .. S ^OR(100,ORIEN,5.1,OCDXCT,0)=DXIEN  ;Store a diagnosis for order
     187 .. S ^OR(100,ORIEN,5.1,"B",DXIEN,OCDXCT)="" ;Index diagnosis for order
     188 S:Y="" Y=1
     189 Q
     190 ;
     191TFSTGS ; Set Treatment Factor strings sequence order
     192 ; TFGBL is order of TxFs in ^OR(100,ORIEN,5) & ^OR(100,ORIEN,5.2)
     193 ; TFGUI is order of TxFs to/from GUI
     194 ; TFTBL is order of TxFs for table SD008 (used in ZCL segment)
     195 ; NOTE: change examples in TFGUIGBL and TFGBLGUI if order changed
     196 S TFGBL="SC^MST^AO^IR^EC^HNC^CV"
     197 S TFGUI="SC^AO^IR^EC^MST^HNC^CV"
     198 S TFTBL="AO^IR^SC^EC^MST^HNC^CV"
     199 Q
     200 ;
     201TFGUIGBL(GUI) ;Convert Treatment Factors from GUI to Global order & format
     202 ;
     203 ; Input:  GUI in CNU?NCU: C=checked, N=not checked, U=unchecked
     204 ; Output: GBL in 1^^^0^?^1^0 (global) format (reordered for storage)
     205 ;
     206 N GBL,J,NTF,TF,TFGBL,TFGUI,TFTBL
     207 S GBL="",NTF=7  ;NTF=# of Treatment Factors (TxF)
     208 ;I $L(GUI)'=NTF Q -1  ;invalid # of TxF
     209 ; Get Treatment Factor sequence order strings
     210 D TFSTGS
     211 ; Convert from GBL to GUI format and sequence
     212 F J=1:1:NTF S TF=$E(GUI,J) D
     213 . S TF($P(TFGUI,U,J))=$S(TF="C":1,TF="U":0,TF="?":"?",1:"")
     214 F J=1:1:NTF S GBL=GBL_U_TF($P(TFGBL,U,J))
     215 Q $P(GBL,U,2,NTF+1)
     216 ;
     217TFGBLGUI(GBL) ;Convert Treatment Factors from Global to GUI order & format
     218 ;
     219 ; Input:  GBL in 1^0^1^1^^0^? (global) format
     220 ; Output: GUI in CCCNUU? (GUI) format (also reordered)
     221 ;
     222 N GUI,J,NTF,TF,TFGBL,TFGUI,TFTBL
     223 S GUI="",NTF=7  ;NCI=# of TxF
     224 ; Get Treatment Factor sequence order strings
     225 D TFSTGS
     226 ; Convert from GUI to GBL format and sequence
     227 F J=1:1:NTF S TF=$P(GBL,U,J) D
     228 . S TF($P(TFGBL,U,J))=$S(TF=1:"C",TF=0:"U",TF="?":"?",1:"N")
     229 F J=1:1:NTF S GUI=GUI_TF($P(TFGUI,U,J))
     230 Q GUI
     231 ;
     232PRVKEY(X) ;Check for active & provider key - to be deleted in CPRS v26
     233 N PTD
     234 Q:'+$G(X) 0
     235 Q:$G(^VA(200,X,0))="" 0
     236 S PTD=+$P(^VA(200,X,0),"^",11)
     237 I $$DT^XLFDT'<PTD,PTD>0 Q 0
     238 Q:$D(^XUSEC("PROVIDER",X)) 1
     239 Q 0
     240 ;
     241ORESKEY(X) ;Does 'X' hold ORES key, returns: 1=true, 0=false
     242 Q:'+$G(X) 0
     243 Q:$D(^XUSEC("ORES",X)) 1
     244 Q 0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA3.m

    r613 r623  
    1 ORWDBA3 ; SLC/GSS Billing Awareness (CIDC) [8/20/03 9:19am]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,243**;Dec 17, 1997;Build 242
    3         ;
    4 ORFMDAT(ORDFN)  ; Return date in FM format regarding order for CSV/CTD/HIPAA
    5         ; Pass in Order IEN
    6         Q ($P($G(^OR(100,ORDFN,8,1,0)),"^",16)\1)
    7         ;
    8 DISPLAY ; Display of BA data from original copied order (ORIT = ORIEN)
    9         ; Displayed in window with all order info and user can accept/edit
    10         ; Note: TxF = Treatment Factor
    11         ; BA data (Dx,TxF's) not editable but in signature window, not in above
    12         ; ORIT defined in ORWDXM1, DISPLAY called from ORWDXM2
    13         ;
    14         ; Input:
    15         ;  ORIT, ILST, and LST() from ORWDXM* routines
    16         ; Output:
    17         ;  ILST and LST() appropriately incremented/populated for order display
    18         ; Variables:
    19         ;  CUN     = TxF's in C, U, or N format
    20         ;  I       = counter
    21         ;  ILST    = line counter, initially from ORWDXM* routines
    22         ;  LST()   = array of lines to output, initially from ORWDXM* routines
    23         ;  NTF     = # of Treatment Factors
    24         ;  ORITARY = ORIT array of 1 needed to access GETTFCI^ORWDBA4
    25         ;  SPCS    = # of characters to space to left of ':'
    26         ;  TF1     = first TxF output? (0/1)
    27         ;  TFGBL   = TxF's in Global stored order
    28         ;  TFGUI   = TxF's in GUI returned order
    29         ;  TFV     = TxF verbiage
    30         ;
    31         N CUN,I,NTF,ORITARY,SPCS,TF1,TFGBL,TFGUI,TFV,Y
    32         S NTF=8,SPCS=28,ORITARY(1)=+ORIT
    33         ; Get Y(+ORIT) string in ORIEN^CUUUCCN^Dx1^Desc1^Dx2^Desc2^... format
    34         D GETTFCI^ORWDBA4(.Y,.ORITARY)
    35         S CUN=$P($G(Y(1)),U,2)  ;CUN = Treatment Factors in CUN syntax
    36         ; First output Diagnosis information - if any
    37         F I=3:2:9 I $P($G(Y(1)),U,I)'="" D
    38         . S ILST=ILST+1,LST(ILST)=$S(I=3:"Diagnoses",1:"")
    39         . S LST(ILST)=LST(ILST)_":"_$P(Y(1),U,I)_" - "_$P(Y(1),U,I+1)
    40         . D FRMTLST
    41         ; Get GUI and GBL Treatment Factor sequence strings
    42         D TFSTGS^ORWDBA1
    43         ; Assumes SC will always be first in sequence! - not likely to change
    44         S ILST=ILST+1
    45         S LST(ILST)="Service Connected:"_$S($E(CUN)="C":"YES",1:"NO")
    46         D FRMTLST
    47         S ILST=ILST+1,LST(ILST)="Treatment Factors:"
    48         ; If no TxF's (no 'C'hecked) {SC output above} then output '<none>'
    49         I '$F($E(CUN,2,NTF),"C") S LST(ILST)=LST(ILST)_"<none>" D FRMTLST Q
    50         S TF1=0  ;No TxF yet output
    51         ; Verbiage for TxF's
    52         S TFV("MST")="MILITARY SEXUAL TRAUMA",TFV("AO")="AGENT ORANGE"
    53         S TFV("IR")="IONIZING RADIATION",TFV("EC")="ENVIRONMENTAL CONTAMINANTS"
    54         S TFV("HNC")="HEAD AND NECK CANCER",TFV("CV")="COMBAT VETERAN"
    55         S TFV("SHD")="SHIPBOARD HAZARD"
    56         ; Output Checked TxF's
    57         F I=2:1:NTF I $E(CUN,I)="C" D
    58         . I 'TF1 S LST(ILST)=LST(ILST)_TFV($P(TFGUI,U,I)),TF1=1 D FRMTLST Q
    59         . S ILST=ILST+1,LST(ILST)=":"_TFV($P(TFGUI,U,I)) D FRMTLST
    60         Q
    61         ;
    62 FRMTLST ; Format the variable LST(ILST) for DISPLAY tag
    63         S LST(ILST)=$J($P(LST(ILST),":"),SPCS)_": "_$P(LST(ILST),":",2)
    64         Q
    65         ;
    66 HINTS(Y)        ; Return HINTS for ORBA Treatment Factors - used by Delphi
    67         ; The hints returned in the Y array will be used in the CPRS GUI and
    68         ; displayed on fly-over of the cursor over the TxF text in the window
    69         ;
    70         ; Input
    71         ;  <none>
    72         ; Output
    73         ;  Y array of the hints for TxF's> Y(#)=TxFA ^ TxF line # ^ hint text
    74         ;    where TxFA is Treatment Factor acronym, e.g., CV=Combat Veteran
    75         ; Variables
    76         ;  CT      = line number count, used in Y(#) where #=CT
    77         ;  I       = incrementor index #
    78         ;  ORTFIEN = the IEN for the TxF in the Help Frame (^DIC(9.2)) file
    79         ;  TF      = TxF acronym
    80         ;  TFLN    = TxF text line number, e.g., ^DIC(9.2,ORTFIEN,1,TFLN,0)
    81         ;  TFS     = string of TxF acronyms
    82         ;  TFV     = TxF description/text
    83         ;
    84         N CT,I,ORTFIEN,TF,TFLN,TFS,TFV
    85         ;
    86         S TFS="SC^MST^AO^IR^EC^HNC^CV^SHD",CT=0
    87         ; Get next TxF from TFS
    88         F I=1:1 S TF=$P(TFS,U,I) Q:TF=""  D
    89         . S ORTFIEN=$O(^DIC(9.2,"B","ORBA-"_TF,"")),TFV="",TFLN=0
    90         . ; Get next line of hint text
    91         . F  S TFLN=$O(^DIC(9.2,ORTFIEN,1,TFLN)) Q:'TFLN  D
    92         .. S CT=CT+1,Y(CT)=TF_U_TFLN_U_^DIC(9.2,ORTFIEN,1,TFLN,0)
    93         Q
    94         ;
    95 DG1(ORDFN,COUNTER,CTVALUE)      ; Create DG1 segment(s) & make call for ZCL seg.
    96         ;
    97         ;  Input
    98         ;    ORDFN      Internal Order ID#
    99         ;    COUNTER    Variable used as counter from calling routine
    100         ;    CTVALUE    Value of COUNTER when DG1 called
    101         ;  Output
    102         ;    DG1 & ZCL HL7 segments
    103         ;
    104         I $$BASTAT^ORWDBA1=0 Q  ;BA not used
    105         N DG13,DXIEN,DXR,DXV,FROMFILE,ICD9,OCT,OREC,ORFMDAT
    106         ; zero order count variable
    107         S OCT=0
    108         ; Get the date of order (for CSV/CTD usage)
    109         S ORFMDAT=$$ORFMDAT(ORDFN)
    110         ; Get the diagnoses for an order
    111         F  S OCT=$O(^OR(100,ORDFN,5.1,OCT)) Q:OCT'?1N.N  D
    112         . S OREC=^OR(100,ORDFN,5.1,OCT,0)
    113         . S DXIEN=$P(OREC,U)  ; DXIEN=pointer to diagnosis (ICD9) file #80
    114         . ; the DXIEN pointer should point to a valid diagnosis (after all is
    115         . ;   was previously entered .. but just in case ...)
    116         . S (DXV,ICD9)=""
    117         . I DXIEN'="" D
    118         .. S DXR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) Q:+DXR=-1
    119         .. ; Get diagnosis verbiage and ICD code
    120         .. S DXV=$P(DXR,U,4),ICD9=$P(DXR,U,2)
    121         . S FROMFILE=80
    122         . S DG13=DXIEN_U_DXV_U_FROMFILE_U_ICD9_U_DXV_U_"ICD9"
    123         . S CTVALUE=CTVALUE+1
    124         . S ORMSG(CTVALUE)="DG1"_"|"_OCT_"||"_DG13_"|||||||||||||"
    125         . D ZCL
    126         S @COUNTER=CTVALUE
    127         Q
    128         ;
    129 ZCL     ;create all the ZCL segments (currently 8 TxF's) for order number OCT
    130         ;
    131         N I,J,TABLE,TF,TFGBL,TFGUI,TFTBL,TFIN,TFS,VALUE
    132         D TFSTGS^ORWDBA1  ;set string sequence of treatment factors
    133         ; TFS is TxF data in ^OR(100,ORIEN,5.2) order
    134         S TFS=$G(^OR(100,ORDFN,5.2)),TABLE=""
    135         ; conversion order from ^OR stored data and Table SD008 for HL7 msg
    136         ; convert so that the ZCL segments will be in Table SD008 order (1-8)
    137         F I=1:1:8 S TF=$P(TFTBL,U,I) F J=1:1:8 I $P(TFGBL,U,J)=TF S TABLE=TABLE_J Q
    138         F TFIN=1:1:8 D
    139         . ; ORMSG counter incremented
    140         . S CTVALUE=CTVALUE+1
    141         . ; TF VALUE=0 for no or 1 for yes (only if not req. is it null)
    142         . S VALUE=$P(TFS,U,$E(TABLE,TFIN))
    143         . I VALUE="?" S VALUE=0  ;temp fix if sending '?' to ancillary???
    144         . ; for Table SD008: OCT=Set ID, SCIN=O/P Classif. Type, VALUE=Value
    145         . S ORMSG(CTVALUE)="ZCL|"_OCT_"|"_TFIN_"|"_VALUE
    146         Q
    147         ;
    148 BDOSTR  ;Store backdoor order DG1 and ZCL messages from HL7
    149         ;Processes one order per entry into BDOSTR, e.g., ROUT(1)
    150         ;Depends upon ORM* routines to set-up a number of variables including
    151         ;  ORMSG array and ORIFN.
    152         ;ORM* routines calling BDOSTR: ORMGMRC, ORMLR, ORMPS, & ORMRA
    153         ;
    154         ; Input:   HL7 messages and related data
    155         ; Output:  ROUT array in Delphi GUI format, i.e.
    156         ;          OrderIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4
    157         ;
    158         ; Variables Used
    159         ;  DG1      = sequential numbered array with a value of DXIEN
    160         ;  I,J      = counters
    161         ;  GUITF    = GUI order treatment factors (TxF)
    162         ;  NDX      = number of diagnoses being passed
    163         ;  NTF      = number of TxF
    164         ;  OBX      = @ORMSG Dx array element # (max of 4 diagnoses stored)
    165         ;  REC      = set to sequential HL7 messages, contains HL7 message data
    166         ;  ROUT     = record sent for storage processing to RCVORCI
    167         ;  TF       = individual TxF values
    168         ;  TFGBL    = TxF acronyms in ^ delimited string in ^OR sequence
    169         ;  TFGUI    = TxF acronyms in ^ delimited string in from GUI sequence
    170         ;  TFTBL    = TxF acronyms in ^ delimited string in Table SD008 sequence
    171         ;  VAL      = individual TxF values
    172         ;  ZCL      = TxF in Table SD008 format and sequence
    173         ;
    174         ; See if CIDC master switch set, if not then no DG1/ZCL seg, to store
    175         I $$BASTAT^ORWDBA1=0 Q  ;CIDC (nee BA) not used
    176         ;
    177         N CPNODE,CT,DG1,I,J,GUITF,NDX,NTF,OBX,REC,ROUT,ORSDCARY,SDCARYA
    178         N TF,TFGBL,TFGUI,TFTBL,VAL,X,ZCL
    179         ;
    180         K ORSDCARY,SDCARYA
    181         D TFSTGS^ORWDBA1  ;set string sequence of treatment factors
    182         S (CT,NDX,OBX)=0,NTF=8,(CPNODE,GUITF,TF,Y,ZCL)="",X="T"
    183         ; Call API to acquire Treatment Factors in force
    184         D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY)  ;DBIA 406
    185         ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV,SHD, e.g., ORSDCARY(3) for SC
    186         ; Convert to character array, e.g., SDCARYA("SC")=""
    187         F I=1:1:NTF S:$D(ORSDCARY(I)) SDCARYA($P("AO^IR^SC^EC^MST^HNC^CV^SHD",U,I))=""
    188         ; Process only four DG1 segments and first set of ZCL segments
    189         F  S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0  S J=$E(@ORMSG@(OBX),1,3) I J="DG1"!(J="ZCL"&($P(@ORMSG@(OBX),"|",2)=1)) D
    190         . S REC=@ORMSG@(OBX)
    191         . ; Setting DG1(#)=DXIEN where # is Dx sequence # (1=primary)
    192         . I J="DG1"&(NDX<4) S DG1($P(REC,"|",2))=$P(REC,U,4),NDX=NDX+1 Q
    193         . ; Create ZCL string of TxFs, e.g., 1101011
    194         . I J="ZCL" D
    195         .. S:$P(REC,"|",4)="" $P(REC,"|",4)=" "
    196         .. S $E(ZCL,$P(REC,"|",3))=$P(REC,"|",4)
    197         ; convert order and format from Table SD008 to GUI
    198         F I=1:1:NTF S TF=$P(TFGUI,U,I) F J=1:1:NTF I $P(TFTBL,U,J)=TF D
    199         . ; If patient does not have that Tx Factor (TF) then ghost in GUI ("N")
    200         . I '$D(SDCARYA(TF)) S GUITF=GUITF_"N" Q
    201         . ; If patient has TF then format for GUI (C=ck'd, U=unck'd, ?=not ans)
    202         . S VAL=$E(ZCL,J),GUITF=GUITF_$S(VAL=1:"C",VAL=0:"U",1:"?")
    203         ; Create output string in a format that can be stored by RCVORCI^ORWDBA1
    204         S ROUT(1)=ORIFN_";11"_GUITF_U_$G(DG1(1))_U_$G(DG1(2))_U_$G(DG1(3))_U_$G(DG1(4))
    205         ; Store diagnoses and treatment factors
    206         D RCVORCI^ORWDBA1(Y,.ROUT)
    207         Q
    208         ;
    209 ERRMSG(VISIT)   ; Error handling and message
    210         ; to be determined
    211         Q
     1ORWDBA3 ; SLC/GSS Billing Awareness (CIDC) [8/20/03 9:19am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195**;Dec 17, 1997
     3 ;
     4ORFMDAT(ORDFN) ; Return date in FM format regarding order for CSV/CTD/HIPAA
     5 ; Pass in Order IEN
     6 Q ($P($G(^OR(100,ORDFN,8,1,0)),"^",16)\1)
     7 ;
     8DISPLAY ; Display of BA data from original copied order (ORIT = ORIEN)
     9 ; Displayed in window with all order info and user can accept/edit
     10 ; Note: TxF = Treatment Factor
     11 ; BA data (Dx,TxF's) not editable but in signature window, not in above
     12 ; ORIT defined in ORWDXM1, DISPLAY called from ORWDXM2
     13 ;
     14 ; Input:
     15 ;  ORIT, ILST, and LST() from ORWDXM* routines
     16 ; Output:
     17 ;  ILST and LST() appropriately incremented/populated for order display
     18 ; Variables:
     19 ;  CUN     = TxF's in C, U, or N format
     20 ;  I       = counter
     21 ;  ILST    = line counter, initially from ORWDXM* routines
     22 ;  LST()   = array of lines to output, initially from ORWDXM* routines
     23 ;  NTF     = # of Treatment Factors
     24 ;  ORITARY = ORIT array of 1 needed to access GETTFCI^ORWDBA4
     25 ;  SPCS    = # of characters to space to left of ':'
     26 ;  TF1     = first TxF output? (0/1)
     27 ;  TFGBL   = TxF's in Global stored order
     28 ;  TFGUI   = TxF's in GUI returned order
     29 ;  TFV     = TxF verbiage
     30 ;
     31 N CUN,I,NTF,ORITARY,SPCS,TF1,TFGBL,TFGUI,TFV,Y
     32 S NTF=7,SPCS=28,ORITARY(1)=+ORIT
     33 ; Get Y(+ORIT) string in ORIEN^CUUUCCN^Dx1^Desc1^Dx2^Desc2^... format
     34 D GETTFCI^ORWDBA4(.Y,.ORITARY)
     35 S CUN=$P($G(Y(1)),U,2)  ;CUN = Treatment Factors in CUN syntax
     36 ; First output Diagnosis information - if any
     37 F I=3:2:9 I $P($G(Y(1)),U,I)'="" D
     38 . S ILST=ILST+1,LST(ILST)=$S(I=3:"Diagnoses",1:"")
     39 . S LST(ILST)=LST(ILST)_":"_$P(Y(1),U,I)_" - "_$P(Y(1),U,I+1)
     40 . D FRMTLST
     41 ; Get GUI and GBL Treatment Factor sequence strings
     42 D TFSTGS^ORWDBA1
     43 ; Assumes SC will always be first in sequence! - not likely to change
     44 S ILST=ILST+1
     45 S LST(ILST)="Service Connected:"_$S($E(CUN)="C":"YES",1:"NO")
     46 D FRMTLST
     47 S ILST=ILST+1,LST(ILST)="Treatment Factors:"
     48 ; If no TxF's (no 'C'hecked) {SC output above} then output '<none>'
     49 I '$F($E(CUN,2,NTF),"C") S LST(ILST)=LST(ILST)_"<none>" D FRMTLST Q
     50 S TF1=0  ;No TxF yet output
     51 ; Verbiage for TxF's
     52 S TFV("MST")="MILITARY SEXUAL TRAUMA",TFV("AO")="AGENT ORANGE"
     53 S TFV("IR")="IONIZING RADIATION",TFV("EC")="ENVIRONMENTAL CONTAMINANTS"
     54 S TFV("HNC")="HEAD AND NECK CANCER",TFV("CV")="COMBAT VETERAN"
     55 ; Output Checked TxF's
     56 F I=2:1:NTF I $E(CUN,I)="C" D
     57 . I 'TF1 S LST(ILST)=LST(ILST)_TFV($P(TFGUI,U,I)),TF1=1 D FRMTLST Q
     58 . S ILST=ILST+1,LST(ILST)=":"_TFV($P(TFGUI,U,I)) D FRMTLST
     59 Q
     60 ;
     61FRMTLST ; Format the variable LST(ILST) for DISPLAY tag
     62 S LST(ILST)=$J($P(LST(ILST),":"),SPCS)_": "_$P(LST(ILST),":",2)
     63 Q
     64 ;
     65HINTS(Y) ; Return HINTS for ORBA Treatment Factors - used by Delphi
     66 ; The hints returned in the Y array will be used in the CPRS GUI and
     67 ; displayed on fly-over of the cursor over the TxF text in the window
     68 ;
     69 ; Input
     70 ;  <none>
     71 ; Output
     72 ;  Y array of the hints for TxF's> Y(#)=TxFA ^ TxF line # ^ hint text
     73 ;    where TxFA is Treatment Factor acronym, e.g., CV=Combat Veteran
     74 ; Variables
     75 ;  CT      = line number count, used in Y(#) where #=CT
     76 ;  I       = incrementor index #
     77 ;  ORTFIEN = the IEN for the TxF in the Help Frame (^DIC(9.2)) file
     78 ;  TF      = TxF acronym
     79 ;  TFLN    = TxF text line number, e.g., ^DIC(9.2,ORTFIEN,1,TFLN,0)
     80 ;  TFS     = string of TxF acronyms
     81 ;  TFV     = TxF description/text
     82 ;
     83 N CT,I,ORTFIEN,TF,TFLN,TFS,TFV
     84 ;
     85 S TFS="SC^MST^AO^IR^EC^HNC^CV",CT=0
     86 ; Get next TxF from TFS
     87 F I=1:1 S TF=$P(TFS,U,I) Q:TF=""  D
     88 . S ORTFIEN=$O(^DIC(9.2,"B","ORBA-"_TF,"")),TFV="",TFLN=0
     89 . ; Get next line of hint text
     90 . F  S TFLN=$O(^DIC(9.2,ORTFIEN,1,TFLN)) Q:'TFLN  D
     91 .. S CT=CT+1,Y(CT)=TF_U_TFLN_U_^DIC(9.2,ORTFIEN,1,TFLN,0)
     92 Q
     93 ;
     94DG1(ORDFN,COUNTER,CTVALUE) ; Create DG1 segment(s) & make call for ZCL seg.
     95 ;
     96 ;  Input
     97 ;    ORDFN      Internal Order ID#
     98 ;    COUNTER    Variable used as counter from calling routine
     99 ;    CTVALUE    Value of COUNTER when DG1 called
     100 ;  Output
     101 ;    DG1 & ZCL HL7 segments
     102 ;
     103 I $$BASTAT^ORWDBA1=0 Q  ;BA not used
     104 N DG13,DXIEN,DXR,DXV,FROMFILE,ICD9,OCT,OREC,ORFMDAT
     105 ; zero order count variable
     106 S OCT=0
     107 ; Get the date of order (for CSV/CTD usage)
     108 S ORFMDAT=$$ORFMDAT(ORDFN)
     109 ; Get the diagnoses for an order
     110 F  S OCT=$O(^OR(100,ORDFN,5.1,OCT)) Q:OCT'?1N.N  D
     111 . S OREC=^OR(100,ORDFN,5.1,OCT,0)
     112 . S DXIEN=$P(OREC,U)  ; DXIEN=pointer to diagnosis (ICD9) file #80
     113 . ; the DXIEN pointer should point to a valid diagnosis (after all is
     114 . ;   was previously entered .. but just in case ...)
     115 . S (DXV,ICD9)=""
     116 . I DXIEN'="" D
     117 .. S DXR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) Q:+DXR=-1
     118 .. ; Get diagnosis verbiage and ICD code
     119 .. S DXV=$P(DXR,U,4),ICD9=$P(DXR,U,2)
     120 . S FROMFILE=80
     121 . S DG13=DXIEN_U_DXV_U_FROMFILE_U_ICD9_U_DXV_U_"ICD9"
     122 . S CTVALUE=CTVALUE+1
     123 . S ORMSG(CTVALUE)="DG1"_"|"_OCT_"||"_DG13_"|||||||||||||"
     124 . D ZCL
     125 S @COUNTER=CTVALUE
     126 Q
     127 ;
     128ZCL ;create all the ZCL segments (currently 7 TxF's) for order number OCT
     129 ;
     130 N I,J,TABLE,TF,TFGBL,TFGUI,TFTBL,TFIN,TFS,VALUE
     131 D TFSTGS^ORWDBA1  ;set string sequence of treatment factors
     132 ; TFS is TxF data in ^OR(100,ORIEN,5.2) order
     133 S TFS=$G(^OR(100,ORDFN,5.2)),TABLE=""
     134 ; conversion order from ^OR stored data and Table SD008 for HL7 msg
     135 ; convert so that the ZCL segments will be in Table SD008 order (1-7)
     136 F I=1:1:7 S TF=$P(TFTBL,U,I) F J=1:1:7 I $P(TFGBL,U,J)=TF S TABLE=TABLE_J Q
     137 F TFIN=1:1:7 D
     138 . ; ORMSG counter incremented
     139 . S CTVALUE=CTVALUE+1
     140 . ; TF VALUE=0 for no or 1 for yes (only if not req. is it null)
     141 . S VALUE=$P(TFS,U,$E(TABLE,TFIN))
     142 . I VALUE="?" S VALUE=0  ;temp fix if sending '?' to ancillary???
     143 . ; for Table SD008: OCT=Set ID, SCIN=O/P Classif. Type, VALUE=Value
     144 . S ORMSG(CTVALUE)="ZCL|"_OCT_"|"_TFIN_"|"_VALUE
     145 Q
     146 ;
     147BDOSTR ;Store backdoor order DG1 and ZCL messages from HL7
     148 ;Processes one order per entry into BDOSTR, e.g., ROUT(1)
     149 ;Depends upon ORM* routines to set-up a number of variables including
     150 ;  ORMSG array and ORIFN.
     151 ;ORM* routines calling BDOSTR: ORMGMRC, ORMLR, ORMPS, & ORMRA
     152 ;
     153 ; Input:   HL7 messages and related data
     154 ; Output:  ROUT array in Delphi GUI format, i.e.
     155 ;          OrderIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4
     156 ;
     157 ; Variables Used
     158 ;  DG1      = sequential numbered array with a value of DXIEN
     159 ;  I,J      = counters
     160 ;  GUITF    = GUI order treatment factors (TxF)
     161 ;  NDX      = number of diagnoses being passed
     162 ;  NTF      = number of TxF
     163 ;  OBX      = @ORMSG Dx array element # (max of 4 diagnoses stored)
     164 ;  REC      = set to sequential HL7 messages, contains HL7 message data
     165 ;  ROUT     = record sent for storage processing to RCVORCI
     166 ;  TF       = individual TxF values
     167 ;  TFGBL    = TxF acronyms in ^ delimited string in ^OR sequence
     168 ;  TFGUI    = TxF acronyms in ^ delimited string in from GUI sequence
     169 ;  TFTBL    = TxF acronyms in ^ delimited string in Table SD008 sequence
     170 ;  VAL      = individual TxF values
     171 ;  ZCL      = TxF in Table SD008 format and sequence
     172 ;
     173 ; See if CIDC master switch set, if not then no DG1/ZCL seg, to store
     174 I $$BASTAT^ORWDBA1=0 Q  ;CIDC (nee BA) not used
     175 ;
     176 N CPNODE,CT,DG1,I,J,GUITF,NDX,NTF,OBX,REC,ROUT,ORSDCARY,SDCARYA
     177 N TF,TFGBL,TFGUI,TFTBL,VAL,X,ZCL
     178 ;
     179 K ORSDCARY,SDCARYA
     180 D TFSTGS^ORWDBA1  ;set string sequence of treatment factors
     181 S (CT,NDX,OBX)=0,NTF=7,(CPNODE,GUITF,TF,Y,ZCL)="",X="T"
     182 ; Call API to acquire Treatment Factors in force
     183 D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY)  ;DBIA 406
     184 ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV, e.g., ORSDCARY(3) for SC
     185 ; Convert to character array, e.g., SDCARYA("SC")=""
     186 F I=1:1:NTF S:$D(ORSDCARY(I)) SDCARYA($P("AO^IR^SC^EC^MST^HNC^CV",U,I))=""
     187 ; Process only four DG1 segments and first set of ZCL segments
     188 F  S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0  S J=$E(@ORMSG@(OBX),1,3) I J="DG1"!(J="ZCL"&($P(@ORMSG@(OBX),"|",2)=1)) D
     189 . S REC=@ORMSG@(OBX)
     190 . ; Setting DG1(#)=DXIEN where # is Dx sequence # (1=primary)
     191 . I J="DG1"&(NDX<4) S DG1($P(REC,"|",2))=$P(REC,U,4),NDX=NDX+1 Q
     192 . ; Create ZCL string of TxFs, e.g., 1101011
     193 . I J="ZCL" D
     194 .. S:$P(REC,"|",4)="" $P(REC,"|",4)=" "
     195 .. S $E(ZCL,$P(REC,"|",3))=$P(REC,"|",4)
     196 ; convert order and format from Table SD008 to GUI
     197 F I=1:1:NTF S TF=$P(TFGUI,U,I) F J=1:1:NTF I $P(TFTBL,U,J)=TF D
     198 . ; If patient does not have that Tx Factor (TF) then ghost in GUI ("N")
     199 . I '$D(SDCARYA(TF)) S GUITF=GUITF_"N" Q
     200 . ; If patient has TF then format for GUI (C=ck'd, U=unck'd, ?=not ans)
     201 . S VAL=$E(ZCL,J),GUITF=GUITF_$S(VAL=1:"C",VAL=0:"U",1:"?")
     202 ; Create output string in a format that can be stored by RCVORCI^ORWDBA1
     203 S ROUT(1)=ORIFN_";11"_GUITF_U_$G(DG1(1))_U_$G(DG1(2))_U_$G(DG1(3))_U_$G(DG1(4))
     204 ; Store diagnoses and treatment factors
     205 D RCVORCI^ORWDBA1(Y,.ROUT)
     206 Q
     207 ;
     208ERRMSG(VISIT) ; Error handling and message
     209 ; to be determined
     210 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA4.m

    r613 r623  
    1 ORWDBA4 ; SLC/GU Billing Awareness - Phase II [11/26/04 15:44]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,243**;Dec 17, 1997;Build 242
    3         ;
    4         ;Miscellaneous CIDC functions utility.
    5         ;
    6         ;External References used by this routine
    7         ;  $$GETS^DIQ            DBIA 2056
    8         ;  GETS^DIQ              DBIA 2056
    9         ;  $$ICDDX^ICDCODE       DBIA 3990
    10         ;  $$TFGBLGUI^ORWDBA1    DBIA none listed
    11         ;  $$SETDXD^ORWDBA2      DBIA none listed
    12         ;  $$NOW^XLFDT           DBIA 10103
    13         ;  $$GET^XPAR            DBIA 2263
    14         ;
    15 GETTFCI(Y,ORIEN)        ;Get Treatment Factors Clinical Indicators
    16         ;Input Variable:
    17         ;  ORIEN    Order Internal Entry Number (array variable)
    18         ;Ouput Variable:
    19         ;  Y        Y(AI)=Order_IEN^Treatment_Factors^ICD9^ICD9_Description
    20         ;           There can be up to 4 ICD9 codes and thier descriptions
    21         ;           ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04
    22         ;Local Variables:
    23         ;  AI       Array Index
    24         ;  CI       Clinical Index
    25         ;  TF       Treatment Factors
    26         ;  TFCI     Treatment Factors Clinical Indicators
    27         N AI,CI,CNT,DXS,TF,TFCI
    28         S U="^",(CNT,TF)=""
    29         F  S CNT=$O(ORIEN(CNT)) Q:CNT=""  D
    30         . S TF=$$GTF(ORIEN(CNT))
    31         . S DXS=$$GDCD(ORIEN(CNT))
    32         . I TF="NNNNNNNN"&(DXS="") Q
    33         . S TFCI(CNT)=ORIEN(CNT)_U_TF_$S(DXS="":"",1:U_DXS)
    34         M Y=TFCI
    35         Q
    36         ;
    37 GTF(IEN)        ;Get Treatment Factors
    38         ;Gets the Treatment Factors for the current order converted to the
    39         ;format used by the CPRS GUI display.
    40         ;
    41         ;Input Variable:
    42         ;  IEN     Internal Entry Number
    43         ;Local Variables:
    44         ;  ORTF    Order Record Treatment Factors
    45         ;  OREM    Order Record Error Message
    46         ;  OTF     Order Treatment Factors
    47         ;          (Converted to GUI values and returned)
    48         N ORTF,OREM,OTF
    49         S OTF=""
    50         D GETS^DIQ(100,IEN,"90;91;92;93;94;95;96;98","I","ORTF","OREM")
    51         S OTF=$G(ORTF(100,IEN_",",90,"I"))
    52         S OTF=OTF_U_$G(ORTF(100,IEN_",",91,"I"))
    53         S OTF=OTF_U_$G(ORTF(100,IEN_",",92,"I"))
    54         S OTF=OTF_U_$G(ORTF(100,IEN_",",93,"I"))
    55         S OTF=OTF_U_$G(ORTF(100,IEN_",",94,"I"))
    56         S OTF=OTF_U_$G(ORTF(100,IEN_",",95,"I"))
    57         S OTF=OTF_U_$G(ORTF(100,IEN_",",96,"I"))
    58         S OTF=OTF_U_$G(ORTF(100,IEN_",",98,"I"))
    59         S OTF=$$TFGBLGUI^ORWDBA1(OTF)
    60         I OTF'="NNNNNNNN" Q OTF
    61         S OTF=""
    62         K ORTF,OREM
    63         D GETS^DIQ(100,IEN,"51;52;53;54;55;56;57;58","I","ORTF","OREM")
    64         S OTF=$G(ORTF(100,IEN_",",51,"I"))
    65         S OTF=OTF_U_$G(ORTF(100,IEN_",",52,"I"))
    66         S OTF=OTF_U_$G(ORTF(100,IEN_",",53,"I"))
    67         S OTF=OTF_U_$G(ORTF(100,IEN_",",54,"I"))
    68         S OTF=OTF_U_$G(ORTF(100,IEN_",",55,"I"))
    69         S OTF=OTF_U_$G(ORTF(100,IEN_",",56,"I"))
    70         S OTF=OTF_U_$G(ORTF(100,IEN_",",57,"I"))
    71         S OTF=OTF_U_$G(ORTF(100,IEN_",",58,"I"))
    72         S OTF=$$TFGBLGUI^ORWDBA1(OTF)
    73         Q OTF
    74         ;
    75 GDCD(IEN)       ;Get Diagnoses Codes / Description
    76         ;Builds and returns a text string delimited by the "^". The text string
    77         ;made from the ICD9 codes associated with the current order and thier
    78         ;descriptions pulled from the ICD DIAGNOSIS file #80. The string can
    79         ;contain up to four diagnoses codes and thier descriptions. The string
    80         ;with all four possiable diagnoses codes is formatted:
    81         ;ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04
    82         ;
    83         ;Input Variable:
    84         ;  IEN
    85         ;Local Variables:
    86         ;  DCD      Diagnosis Code Description (retrun variable)
    87         ;  DXDT     Diagnosis Date (either Order date or system date)
    88         ;  DXD      Diagnosis Description
    89         ;  DXIEN    Diagnosis Internal Entry Number
    90         ;  ICD9     ICD9 code (for GUI display)
    91         ;  IENS     Internale Entry Number Sequence
    92         ;           (Array index variable for data returned from lookup)
    93         ;  ORRF     Order Record Found (returned data from lookup)
    94         ;  OREM     Order Record Error Message
    95         N DCD,DXDT,DXD,DXIEN,ICD9,IENS,ORRF,OREM
    96         S DCD=""
    97         D GETS^DIQ(100,IEN,".8*;5.1*","I","ORRF","OREM")
    98         I $D(ORRF) D
    99         . S DXDT=""
    100         . I $D(ORRF(100.008)) S DXDT=$G(ORRF(100.008,"1,"_IEN_",",.01,"I"))
    101         . I DXDT="" S DXDT=$$NOW^XLFDT
    102         . I $D(ORRF(100.051)) D
    103         .. S IENS="" F  S IENS=$O(ORRF(100.051,IENS)) Q:IENS=""  D
    104         ... I ORRF(100.051,IENS,.01,"I")="" S DCD=DCD_U Q
    105         ... S DXIEN=ORRF(100.051,IENS,.01,"I")
    106         ... S ICD9=$$GET1^DIQ(80,DXIEN,.01,"")
    107         ... S DXD=$$SETDXD^ORWDBA2($P($$ICDDX^ICDCODE(ICD9,DT),U,4))
    108         ... S DCD=$S(DCD="":ICD9_U_DXD,1:DCD_U_ICD9_U_DXD)
    109         Q DCD
    110         ;
    111 GETBAUSR(Y,ORCIEN)      ;GUI RPC CALL
    112         ;Get Billing Awareness By User parameter value
    113         ;Gets and returns the value of the Enabled Billing Awareness By User
    114         ;parameter assigned to a provider.
    115         ;Input Variable:
    116         ;  ORCIEN    Ordering Clinician's Internal Entry Number
    117         ;Output Variable:
    118         ;  Y         Parameter value, 1 if enabled, 0 if disabled
    119         S Y=$$GET^XPAR(ORCIEN_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q")
    120         Q
     1ORWDBA4 ; SLC/GU Billing Awareness - Phase II [11/26/04 15:44]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195**;Dec 17, 1997
     3 ;
     4 ;Miscellaneous CIDC functions utility.
     5 ;
     6 ;External References used by this routine
     7 ;  $$GETS^DIQ            DBIA 2056
     8 ;  GETS^DIQ              DBIA 2056
     9 ;  $$ICDDX^ICDCODE       DBIA 3990
     10 ;  $$TFGBLGUI^ORWDBA1    DBIA none listed
     11 ;  $$SETDXD^ORWDBA2      DBIA none listed
     12 ;  $$NOW^XLFDT           DBIA 10103
     13 ;  $$GET^XPAR            DBIA 2263
     14 ;
     15GETTFCI(Y,ORIEN) ;Get Treatment Factors Clinical Indicators
     16 ;Input Variable:
     17 ;  ORIEN    Order Internal Entry Number (array variable)
     18 ;Ouput Variable:
     19 ;  Y        Y(AI)=Order_IEN^Treatment_Factors^ICD9^ICD9_Description
     20 ;           There can be up to 4 ICD9 codes and thier descriptions
     21 ;           ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04
     22 ;Local Variables:
     23 ;  AI       Array Index
     24 ;  CI       Clinical Index
     25 ;  TF       Treatment Factors
     26 ;  TFCI     Treatment Factors Clinical Indicators
     27 N AI,CI,CNT,DXS,TF,TFCI
     28 S U="^",(CNT,TF)=""
     29 F  S CNT=$O(ORIEN(CNT)) Q:CNT=""  D
     30 . S TF=$$GTF(ORIEN(CNT))
     31 . S DXS=$$GDCD(ORIEN(CNT))
     32 . I TF="NNNNNNN"&(DXS="") Q
     33 . S TFCI(CNT)=ORIEN(CNT)_U_TF_$S(DXS="":"",1:U_DXS)
     34 M Y=TFCI
     35 Q
     36 ;
     37GTF(IEN) ;Get Treatment Factors
     38 ;Gets the Treatment Factors for the current order converted to the
     39 ;format used by the CPRS GUI display.
     40 ;
     41 ;Input Variable:
     42 ;  IEN     Internal Entry Number
     43 ;Local Variables:
     44 ;  ORTF    Order Record Treatment Factors
     45 ;  OREM    Order Record Error Message
     46 ;  OTF     Order Treatment Factors
     47 ;          (Converted to GUI values and returned)
     48 N ORTF,OREM,OTF
     49 S OTF=""
     50 D GETS^DIQ(100,IEN,"90;91;92;93;94;95;96","I","ORTF","OREM")
     51 S OTF=$G(ORTF(100,IEN_",",90,"I"))
     52 S OTF=OTF_U_$G(ORTF(100,IEN_",",91,"I"))
     53 S OTF=OTF_U_$G(ORTF(100,IEN_",",92,"I"))
     54 S OTF=OTF_U_$G(ORTF(100,IEN_",",93,"I"))
     55 S OTF=OTF_U_$G(ORTF(100,IEN_",",94,"I"))
     56 S OTF=OTF_U_$G(ORTF(100,IEN_",",95,"I"))
     57 S OTF=OTF_U_$G(ORTF(100,IEN_",",96,"I"))
     58 S OTF=$$TFGBLGUI^ORWDBA1(OTF)
     59 I OTF'="NNNNNNN" Q OTF
     60 S OTF=""
     61 K ORTF,OREM
     62 D GETS^DIQ(100,IEN,"51;52;53;54;55;56;57","I","ORTF","OREM")
     63 S OTF=$G(ORTF(100,IEN_",",51,"I"))
     64 S OTF=OTF_U_$G(ORTF(100,IEN_",",52,"I"))
     65 S OTF=OTF_U_$G(ORTF(100,IEN_",",53,"I"))
     66 S OTF=OTF_U_$G(ORTF(100,IEN_",",54,"I"))
     67 S OTF=OTF_U_$G(ORTF(100,IEN_",",55,"I"))
     68 S OTF=OTF_U_$G(ORTF(100,IEN_",",56,"I"))
     69 S OTF=OTF_U_$G(ORTF(100,IEN_",",57,"I"))
     70 S OTF=$$TFGBLGUI^ORWDBA1(OTF)
     71 Q OTF
     72 ;
     73GDCD(IEN) ;Get Diagnoses Codes / Description
     74 ;Builds and returns a text string delimited by the "^". The text string
     75 ;made from the ICD9 codes associated with the current order and thier
     76 ;descriptions pulled from the ICD DIAGNOSIS file #80. The string can
     77 ;contain up to four diagnoses codes and thier descriptions. The string
     78 ;with all four possiable diagnoses codes is formatted:
     79 ;ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04
     80 ;
     81 ;Input Variable:
     82 ;  IEN
     83 ;Local Variables:
     84 ;  DCD      Diagnosis Code Description (retrun variable)
     85 ;  DXDT     Diagnosis Date (either Order date or system date)
     86 ;  DXD      Diagnosis Description
     87 ;  DXIEN    Diagnosis Internal Entry Number
     88 ;  ICD9     ICD9 code (for GUI display)
     89 ;  IENS     Internale Entry Number Sequence
     90 ;           (Array index variable for data returned from lookup)
     91 ;  ORRF     Order Record Found (returned data from lookup)
     92 ;  OREM     Order Record Error Message
     93 N DCD,DXDT,DXD,DXIEN,ICD9,IENS,ORRF,OREM
     94 S DCD=""
     95 D GETS^DIQ(100,IEN,".8*;5.1*","I","ORRF","OREM")
     96 I $D(ORRF) D
     97 . S DXDT=""
     98 . I $D(ORRF(100.008)) S DXDT=$G(ORRF(100.008,"1,"_IEN_",",.01,"I"))
     99 . I DXDT="" S DXDT=$$NOW^XLFDT
     100 . I $D(ORRF(100.051)) D
     101 .. S IENS="" F  S IENS=$O(ORRF(100.051,IENS)) Q:IENS=""  D
     102 ... I ORRF(100.051,IENS,.01,"I")="" S DCD=DCD_U Q
     103 ... S DXIEN=ORRF(100.051,IENS,.01,"I")
     104 ... S ICD9=$$GET1^DIQ(80,DXIEN,.01,"")
     105 ... S DXD=$$SETDXD^ORWDBA2($P($$ICDDX^ICDCODE(ICD9,DT),U,4))
     106 ... S DCD=$S(DCD="":ICD9_U_DXD,1:DCD_U_ICD9_U_DXD)
     107 Q DCD
     108 ;
     109GETBAUSR(Y,ORCIEN) ;GUI RPC CALL
     110 ;Get Billing Awareness By User parameter value
     111 ;Gets and returns the value of the Enabled Billing Awareness By User
     112 ;parameter assigned to a provider.
     113 ;Input Variable:
     114 ;  ORCIEN    Ordering Clinician's Internal Entry Number
     115 ;Output Variable:
     116 ;  Y         Parameter value, 1 if enabled, 0 if disabled
     117 S Y=$$GET^XPAR(ORCIEN_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q")
     118 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA7.m

    r613 r623  
    1 ORWDBA7 ;;SLC/GSS Billing Awareness (CIDC-Clinical Indicators Data Capture)
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 BDOEDIT ; Backdoor entered orders edit in CPRS - entry point
    5         ; Data Flow> Ancillary creates a back door order which is incomplete
    6         ;            and thus edited in CPRS GUI. The ancillary needs to know
    7         ;            what Dx and TF's are edited thus this tag calls three
    8         ;            ancillary APIs, passing the Dx and TF data to them.
    9         ;
    10         ; Variable  Description
    11         ; ANCILARY  Acronym of ancillary/package relative to order
    12         ; DXN       Diagnosis sequence number in ^OR file
    13         ; MSG       Error message
    14         ; ORDX      Array of diagnoses (1-n) with value from ICD file (#80)
    15         ; ORIFN     Order internal reference number (defined in ORCSEND)
    16         ; ORITEM    Package reference or ^OR(100,ORIFN,4)
    17         ; ORSCEI    String of Treatment Factors in table SD008 order/format
    18         ; PTIEN     Patient IEN
    19         ; TAGROU    Tag^Routine of ancillary routine to store edited data
    20         ; TFO       Treatment Factors in ^OR (GBL) order
    21         ;
    22         ; If CIDC master switch set, then no back door orders to store
    23         I $$BASTAT^ORWDBA1=0 Q  ;CIDC (nee BA) not used
    24         ; If ORIFN not defined (God only knows why) then log error and quit
    25         I '$D(ORIFN) S MSG="ORIFN not defined" D VAR,EN^ORERR(MSG,"",.VAR) Q
    26         ;
    27         N ANCILARY,DXN,MSG,ORDX,ORITEM,ORSCEI,PTIEN,RT,SUCCESS,TAGROU,TFO,VAR
    28         ;
    29         S DXN=0,(RT,SUCCESS)="",PTIEN=+$P($G(^OR(100,ORIFN,0)),U,2)
    30         ; Package (ancillary) reference data
    31         S ORITEM=$G(^OR(100,ORIFN,4))
    32         ; Create an array (ORDX) of diagnoses
    33         F  S DXN=$O(^OR(100,ORIFN,5.1,DXN)) Q:'DXN  D
    34         . S ORDX(DXN)=$G(^OR(100,ORIFN,5.1,DXN,0))
    35         ; Treatment Factors - converted and reformatted
    36         S ORSCEI=$$TFGBLTBL($G(^OR(100,ORIFN,5.2)))
    37         ; Get the acronym of the package generating this order
    38         S ANCILARY=$P($G(^DIC(9.4,$P($G(^OR(100,ORIFN,0)),U,14),0)),U,2)
    39         ; Send data to the appropriate ancillary API based on package
    40         D OUTPUT
    41         ; If ancillary routine or tag w/in the routine doesn't exist check
    42         I 'RT D
    43         . S MSG="NON-EXISTANT ROUTINE/TAG FOR "_ANCILARY
    44         . D VAR,EN^ORERR(MSG,"",.VAR)
    45         ; If we don't get back a thumbs-up from the ancillary re: the order data
    46         I 'SUCCESS,RT D
    47         . S MSG="ANCILLARY API RETURNED ERROR FOR CPRS EDITED BACK DOOR DATA"
    48         . D VAR,EN^ORERR(MSG,"",.VAR)
    49         Q
    50         ;
    51 OUTPUT  ; Call ancillary's API to store data after checking for it's existence
    52         ;
    53         ; Laboratory
    54         I ANCILARY?1"LR".U D  Q
    55         . S RT=$$CKROUTAG("UPDOR^LRBEBA4") Q:'RT
    56         . S SUCCESS=$$UPDOR^LRBEBA4(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI)  ;IA 4775
    57         ;
    58         ; Pharmacy
    59         I ANCILARY?1"PS".U D  Q
    60         . S RT=$$CKROUTAG("EN^PSOHLNE3") Q:'RT
    61         . S SUCCESS=$$EN^PSOHLNE3(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI)  ;IA 4666
    62         ;
    63         ; Radiolgy
    64         I ANCILARY?1"RA".U D  Q
    65         . S RT=$$CKROUTAG("CPRSUPD^RABWORD1") Q:'RT
    66         . S SUCCESS=$$CPRSUPD^RABWORD1(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4771
    67         Q
    68         ;
    69 CKROUTAG(TAGROU)        ;Check if valid tag and routine
    70         ; Temporary check until all the ancillaries have their API's built
    71         Q $L($T(@TAGROU))
    72         ;
    73 TFGBLTBL(GBL)   ;Convert Tx Factors from Global to TBL (HL7) order & format
    74         ; Note: this does not set Tx Factors in ZCL segment format but rather
    75         ;       AO^IR^SC^EC^MST^HNC^CV^SHD ('^' delimited string) format
    76         ;
    77         ; Input:  GBL in 1^1^0^0^^^0^ (global) format
    78         ; Output: TBL in 0^0^1^^1^^0^ (TBL) format (also reordered)
    79         ;
    80         N J,NTF,TBL,TF,TFGBL,TFGUI,TFTBL
    81         S TBL="",NTF=8  ;NCI=# of TxF
    82         ; Get Treatment Factor sequence order strings
    83         D TFSTGS^ORWDBA1
    84         ; Convert from GBL to TBL format and sequence
    85         F J=1:1:NTF S TF=$P(GBL,U,J) D
    86         . ;OK..just in case there is a '?' we'll return a null for a '?'
    87         . S TF($P(TFGBL,U,J))=$S(TF=1:1,TF=0:0,TF="?":"",1:"")
    88         F J=1:1:NTF S TBL=TBL_U_TF($P(TFTBL,U,J))
    89         ; Remove the first '^' and pass TBL formatted TF's
    90         Q $E(TBL,2,99)
    91         ;
    92 VAR     ;Create VAR array for tracking error in ^ORYX("ORERR",err#)
    93         S VAR("DFN")=PTIEN
    94         S VAR("ORITEM")=ORITEM
    95         S VAR("ORIFN")=ORIFN
    96         M VAR("ORDX")=ORDX
    97         S VAR("ORSCEI")=ORSCEI
    98         Q
    99         ;
    100 ISWITCH(Y,DFN)  ;Return 0 if don't ask (no ins) or 1 to ask CIDC quest (yes ins)
    101         S Y=$$CIDC^IBBAPI(DFN)
    102         Q
    103         ;
    104 GETIEN9(Y,ICD9) ;Return IEN for an ICD9 code (RPC: ORWDBA7 GETIEN9)
    105         S Y=$P($$CODEN^ICDCODE(ICD9,80),"~")
    106         Q
    107         ;
    108 CONDTLD ;Consult Detailed Display Compile for CIDC/BA (called by GMRCSLM2)
    109         ; Input:  ORIFN and GMRCCT defined in GMRCSLM2
    110         ; Output: CIDCARY = array of CIDC display lines for GMRCSLM2 display
    111         N BGNRCCT,DXIEN,DXOF,DXV,EYE,ICD9,ICDR,LINE,OCT,ORFMDAT,TF
    112         S BGNRCCT=GMRCCT,OCT=0
    113         ; Get the date of the order for CSV/CTD usage
    114         S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN)
    115         ; $O through diagnoses for an order
    116         F  S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N  D
    117         . S DXOF="               "
    118         . ; DXIEN=Dx IEN
    119         . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0)
    120         . ; Get Dx record for date ORFMDAT
    121         . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT)
    122         . ; Get Dx verbiage and ICD code
    123         . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2)
    124         . I OCT=1 D
    125         .. S CIDCARY(GMRCCT,0)=" ",GMRCCT=GMRCCT+1 ;blank line
    126         .. S CIDCARY(GMRCCT,0)="Clinical Indicators",GMRCCT=GMRCCT+1
    127         .. S DXOF="Diagnosis of:  "
    128         . S LINE=DXOF_ICD9_" - "_DXV
    129         . S CIDCARY(GMRCCT,0)=LINE,GMRCCT=GMRCCT+1
    130         I OCT'="" D  ;if there are diagnoses then show Treatment Factors
    131         . S LINE="For conditions related to:    "
    132         . F EYE=1:1:8 S TF=$P(^OR(100,ORIFN,5.2),U,EYE) I TF D
    133         .. S CIDCARY(GMRCCT,0)=LINE_$$SC^ORQ21(EYE)
    134         .. S X=$$REPEAT^XLFSTR(" ",30),GMRCCT=GMRCCT+1
    135         Q
     1ORWDBA7 ;;SLC/GSS Billing Awareness (CIDC-Clinical Indicators Data Capture)
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,215**;Dec 17, 1997
     3 ;
     4BDOEDIT ; Backdoor entered orders edit in CPRS - entry point
     5 ; Data Flow> Ancillary creates a back door order which is incomplete
     6 ;            and thus edited in CPRS GUI. The ancillary needs to know
     7 ;            what Dx and TF's are edited thus this tag calls three
     8 ;            ancillary APIs, passing the Dx and TF data to them.
     9 ;
     10 ; Variable  Description
     11 ; ANCILARY  Acronym of ancillary/package relative to order
     12 ; DXN       Diagnosis sequence number in ^OR file
     13 ; MSG       Error message
     14 ; ORDX      Array of diagnoses (1-n) with value from ICD file (#80)
     15 ; ORIFN     Order internal reference number (defined in ORCSEND)
     16 ; ORITEM    Package reference or ^OR(100,ORIFN,4)
     17 ; ORSCEI    String of Treatment Factors in table SD008 order/format
     18 ; PTIEN     Patient IEN
     19 ; TAGROU    Tag^Routine of ancillary routine to store edited data
     20 ; TFO       Treatment Factors in ^OR (GBL) order
     21 ;
     22 ; If CIDC master switch set, then no back door orders to store
     23 I $$BASTAT^ORWDBA1=0 Q  ;CIDC (nee BA) not used
     24 ; If ORIFN not defined (God only knows why) then log error and quit
     25 I '$D(ORIFN) S MSG="ORIFN not defined" D VAR,EN^ORERR(MSG,"",.VAR) Q
     26 ;
     27 N ANCILARY,DXN,MSG,ORDX,ORITEM,ORSCEI,PTIEN,RT,SUCCESS,TAGROU,TFO,VAR
     28 ;
     29 S DXN=0,(RT,SUCCESS)="",PTIEN=+$P($G(^OR(100,ORIFN,0)),U,2)
     30 ; Package (ancillary) reference data
     31 S ORITEM=$G(^OR(100,ORIFN,4))
     32 ; Create an array (ORDX) of diagnoses
     33 F  S DXN=$O(^OR(100,ORIFN,5.1,DXN)) Q:'DXN  D
     34 . S ORDX(DXN)=$G(^OR(100,ORIFN,5.1,DXN,0))
     35 ; Treatment Factors - converted and reformatted
     36 S ORSCEI=$$TFGBLTBL($G(^OR(100,ORIFN,5.2)))
     37 ; Get the acronym of the package generating this order
     38 S ANCILARY=$P($G(^DIC(9.4,$P($G(^OR(100,ORIFN,0)),U,14),0)),U,2)  ;D???
     39 ; Send data to the appropriate ancillary API based on package
     40 D OUTPUT
     41 ; If ancillary routine or tag w/in the routine doesn't exist check
     42 I 'RT D
     43 . S MSG="NON-EXISTANT ROUTINE/TAG FOR "_ANCILARY
     44 . D VAR,EN^ORERR(MSG,"",.VAR)
     45 ; If we don't get back a thumbs-up from the ancillary re: the order data
     46 I 'SUCCESS,RT D
     47 . S MSG="ANCILLARY API RETURNED ERROR FOR CPRS EDITED BACK DOOR DATA"
     48 . D VAR,EN^ORERR(MSG,"",.VAR)
     49 Q
     50 ;
     51OUTPUT ; Call ancillary's API to store data after checking for it's existence
     52 ;
     53 ; Laboratory
     54 I ANCILARY?1"LR".U D  Q
     55 . S RT=$$CKROUTAG("UPDOR^LRBEBA4") Q:'RT
     56 . S SUCCESS=$$UPDOR^LRBEBA4(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI)  ;IA 4775
     57 ;
     58 ; Pharmacy
     59 I ANCILARY?1"PS".U D  Q
     60 . S RT=$$CKROUTAG("EN^PSOHLNE3") Q:'RT
     61 . S SUCCESS=$$EN^PSOHLNE3(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI)  ;IA 4666
     62 ;
     63 ; Radiolgy
     64 I ANCILARY?1"RA".U D  Q
     65 . S RT=$$CKROUTAG("CPRSUPD^RABWORD1") Q:'RT
     66 . S SUCCESS=$$CPRSUPD^RABWORD1(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4771
     67 Q
     68 ;
     69CKROUTAG(TAGROU) ;Check if valid tag and routine
     70 ; Temporary check until all the ancillaries have their API's built
     71 Q $L($T(@TAGROU))
     72 ;
     73TFGBLTBL(GBL) ;Convert Tx Factors from Global to TBL (HL7) order & format
     74 ; Note: this does not set Tx Factors in ZCL segment format but rather
     75 ;       AO^IR^SC^EC^MST^HNC^CV ('^' delimited string) format
     76 ;
     77 ; Input:  GBL in 1^1^0^0^^^0 (global) format
     78 ; Output: TBL in 0^0^1^^1^^0 (TBL) format (also reordered)
     79 ;
     80 N J,NTF,TBL,TF,TFGBL,TFGUI,TFTBL
     81 S TBL="",NTF=7  ;NCI=# of TxF
     82 ; Get Treatment Factor sequence order strings
     83 D TFSTGS^ORWDBA1
     84 ; Convert from GBL to TBL format and sequence
     85 F J=1:1:NTF S TF=$P(GBL,U,J) D
     86 . ;OK..just in case there is a '?' we'll return a null for a '?'
     87 . S TF($P(TFGBL,U,J))=$S(TF=1:1,TF=0:0,TF="?":"",1:"")
     88 F J=1:1:NTF S TBL=TBL_U_TF($P(TFTBL,U,J))
     89 ; Remove the first '^' and pass TBL formatted TF's
     90 Q $E(TBL,2,99)
     91 ;
     92VAR ;Create VAR array for tracking error in ^ORYX("ORERR",err#)
     93 S VAR("DFN")=PTIEN
     94 S VAR("ORITEM")=ORITEM
     95 S VAR("ORIFN")=ORIFN
     96 M VAR("ORDX")=ORDX
     97 S VAR("ORSCEI")=ORSCEI
     98 Q
     99 ;
     100ISWITCH(Y,DFN) ;Return 0 if don't ask (no ins) or 1 to ask CIDC quest (yes ins)
     101 S Y=$$CIDC^IBBAPI(DFN)
     102 Q
     103 ;
     104GETIEN9(Y,ICD9) ;Return IEN for an ICD9 code (RPC: ORWDBA7 GETIEN9)
     105 S Y=$P($$CODEN^ICDCODE(ICD9,80),"~")
     106 Q
     107 ;
     108CONDTLD ;Consult Detailed Display Compile for CIDC/BA (called by GMRCSLM2)
     109 ; Input:  ORIFN and GMRCCT defined in GMRCSLM2
     110 ; Output: CIDCARY = array of CIDC display lines for GMRCSLM2 display
     111 N BGNRCCT,DXIEN,DXOF,DXV,EYE,ICD9,ICDR,LINE,OCT,ORFMDAT,TF
     112 S BGNRCCT=GMRCCT,OCT=0
     113 ; Get the date of the order for CSV/CTD usage
     114 S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN)
     115 ; $O through diagnoses for an order
     116 F  S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N  D
     117 . S DXOF="               "
     118 . ; DXIEN=Dx IEN
     119 . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0)
     120 . ; Get Dx record for date ORFMDAT
     121 . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT)
     122 . ; Get Dx verbiage and ICD code
     123 . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2)
     124 . I OCT=1 D
     125 .. S CIDCARY(GMRCCT,0)=" ",GMRCCT=GMRCCT+1 ;blank line
     126 .. S CIDCARY(GMRCCT,0)="Clinical Indicators",GMRCCT=GMRCCT+1
     127 .. S DXOF="Diagnosis of:  "
     128 . S LINE=DXOF_ICD9_" - "_DXV
     129 . S CIDCARY(GMRCCT,0)=LINE,GMRCCT=GMRCCT+1
     130 I OCT'="" D  ;if there are diagnoses then show Treatment Factors
     131 . S LINE="For conditions related to:    "
     132 . F EYE=1:1:7 S TF=$P(^OR(100,ORIFN,5.2),U,EYE) I TF D
     133 .. S CIDCARY(GMRCCT,0)=LINE_$$SC^ORQ21(EYE)
     134 .. S X=$$REPEAT^XLFSTR(" ",30),GMRCCT=GMRCCT+1
     135 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDFH.m

    r613 r623  
    1 ORWDFH  ; SLC/KCM/JLI - Diet Order calls for Windows Dialogs ;12/12/00  14:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,141,187,215,243**;Dec 17, 1997;Build 242
    3 TXT(LST,DFN)       ; Return text of current & future diets for a patient
    4         S LST(1)="Current Diet:  "_$$DIET^ORCDFH(DFN)
    5         N FUTLST D FUT(.FUTLST,DFN) I $D(FUTLST)>1 D
    6         . S LST(2)="Future Diet Orders:",ILST=2
    7         . S I=0 F  S I=$O(FUTLST(I)) Q:'I  D
    8         . . S X=$$FMTE^XLFDT(I,2)_"  "_$P(FUTLST(I),U,2)
    9         . . S LST(ILST)=$S(ILST=2:"Future Diet Orders:  "_X,1:"   "_X)
    10         . . S ILST=ILST+1
    11         Q
    12 FUT(LST,DFN)       ; Return a list of future diet orders
    13         N DGRP,NXTDT,ORIFN,ORVP,ORTX
    14         S ORVP=DFN_";DPT(",DGRP=$O(^ORD(100.98,"B","DO",0)),NXTDT=$$NOW^XLFDT
    15         F  S NXTDT=$O(^OR(100,"AW",ORVP,DGRP,NXTDT)) Q:NXTDT'>0  D
    16         . S ORIFN=+$O(^OR(100,"AW",ORVP,DGRP,NXTDT,0))
    17         . I $P($G(^OR(100,ORIFN,3)),U,3)'=8 Q  ; only scheduled diets
    18         . D TEXT^ORQ12(.ORTX,ORIFN) S LST(NXTDT)=NXTDT_U_$G(ORTX(1))
    19         Q
    20 PARAM(ORLST,ORVP,ORLOC)  ; Return dietetics parameters for a patient at a location
    21         ; ORLOC: hospital location ptr to ^SC #44
    22         ; ORLST(1)=EB1^EB2^EB3^LB1^LB2^LB3^EN1^EN2^...LE2^LE3
    23         ; ORLST(2)=BAB^BAE^NAB^NAE^EAB^EAE^BegB^BegN^BegE^Bagged
    24         ; ORLST(3)=type of service^RegIEN^NPOIEN^EarlyIEN^LateIEN^TFIFN
    25         ; ORLST(4)=max days in future for outpatient recurring meals
    26         ; ORLST(5)=default outpatient diet
    27         Q:'+ORVP
    28         N X,IEN,CURTM
    29         S ORVP=+ORVP_";DPT(",ORLOC=+ORLOC
    30         S CURTM=$$NOW^XLFDT
    31         I +$G(^SC(ORLOC,42)) S ORLOC=$G(^SC(ORLOC,42))_";DIC(42"
    32         E  S ORLOC=ORLOC_";SC("
    33         D EN1^FHWOR8(ORLOC,.ORLST)
    34         ;
    35         I '$L($G(ORLST(3))) S ORLST(3)="T"
    36         S $P(ORLST(3),U,2)=$O(^ORD(101.43,"S.DIET","REGULAR",0))
    37         S $P(ORLST(3),U,3)=$O(^ORD(101.43,"S.DIET","NPO",0))
    38         S $P(ORLST(3),U,4)=$O(^ORD(101.43,"S.E/L T","EARLY TRAY",0))
    39         S $P(ORLST(3),U,5)=$O(^ORD(101.43,"S.E/L T","LATE TRAY",0))
    40         N TF S TF=$$CURRENT^ORCDFH("TF") I $L(TF,";")=1 S TF=TF_";1"
    41         I TF,'$$FUTURE^ORCDFH("EFFECTIVE DATE/TIME") S $P(ORLST(3),U,6)=TF
    42         I $$VERSION^XPDUTL("FH")>5 D
    43         . S ORLST(4)=$$MAXDAYS^FHOMAPI(ORLOC)
    44         . D DIETLST^FHOMAPI Q:'$G(FHDIET(1))
    45         . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(1),U,1)_";99FHD",0)) Q:+IEN=0
    46         . S X=^ORD(101.43,"S.DIET",$P(FHDIET(1),U,2),IEN)
    47         . I +$P(X,U,3),$P(X,U,3)<CURTM Q
    48         . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q
    49         . S ORLST(5)=+$G(IEN)
    50         Q
    51 ATTR(REC,OI)       ; Return OI^Text^Type^Precedence^AskExpire for a diet
    52         I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT S REC="0^"_$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." Q
    53         S REC=OI_U_$P($G(^ORD(101.43,OI,0)),U)_U_$G(^("FH"))
    54         Q
    55 DIETS(Y,FROM,DIR)             ; Return a subset of active diets, including NPO
    56         ; Y(n)=IEN^.01 Name^.01 Name  -or-  IEN^Synonym <.01 Name>^.01 Name
    57         N I,IEN,CNT,X,CURTM
    58         S I=0,CNT=44,CURTM=$$NOW^XLFDT
    59         F  Q:I'<CNT  S FROM=$O(^ORD(101.43,"S.DIET",FROM),DIR) Q:FROM=""  D
    60         . S IEN=0 F  S IEN=$O(^ORD(101.43,"S.DIET",FROM,IEN)) Q:'IEN  D
    61         . . S X=^ORD(101.43,"S.DIET",FROM,IEN)
    62         . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
    63         . . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q
    64         . . S I=I+1
    65         . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
    66         . . E  S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
    67         Q
    68 OPDIETS(ORY,FROM,DIR)     ;Return a list of up to 5 outpatient diets from file 119.9
    69         N X,I,J,IEN,CURTM,SYNCNT,SYNTOT,FHDIET
    70         D DIETLST^FHOMAPI
    71         S CURTM=$$NOW^XLFDT,I=0,SYNTOT=1
    72         F  S I=$O(FHDIET(I)) Q:'I  D
    73         . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(I),U,1)_";99FHD",0)) Q:+IEN=0
    74         . S X=^ORD(101.43,"S.DIET",$P(FHDIET(I),U,2),IEN)
    75         . I +$P(X,U,3),$P(X,U,3)<CURTM Q
    76         . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q
    77         . S X=$P(^ORD(101.43,IEN,0),U,1)
    78         . S SYNCNT=$P($G(^ORD(101.43,IEN,2,0)),U,4),J=0
    79         . S ORY(X)=IEN_U_X_U_X
    80         . I +SYNCNT  D  Q
    81         . . S SYNTOT=SYNTOT+SYNCNT
    82         . . F  S J=$O(^ORD(101.43,IEN,2,J)) Q:'J  D
    83         . . . S ORY(^ORD(101.43,IEN,2,J,0))=IEN_U_^ORD(101.43,IEN,2,J,0)_$C(9)_"<"_X_">"_U_X
    84         Q
    85 TFPROD(Y)           ; Return a list of active tubefeeding products
    86         N I,IEN,NAM,X,CURTM
    87         S I=0,NAM="",CURTM=$$NOW^XLFDT
    88         F  S NAM=$O(^ORD(101.43,"S.TF",NAM)) Q:NAM=""  D
    89         . S IEN=0 F  S IEN=$O(^ORD(101.43,"S.TF",NAM,IEN)) Q:'IEN  D
    90         . . S X=^ORD(101.43,"S.TF",NAM,IEN)
    91         . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
    92         . . S I=I+1
    93         . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
    94         . . E  S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
    95         Q
    96 QTY2CC(VAL,PRD,STR,QTY)     ; Return cc's given a product, strength, & quantity
    97         N X,VQTY,DUR
    98         S VQTY=$$VALIDQTY^ORCDFHTF(QTY) I '$L(VQTY)!('PRD)!('STR) S VAL="" Q
    99         S PRD=+$P($G(^ORD(101.43,PRD,0)),U,2)
    100         S DUR=$P(VQTY," X ",2) I $L(DUR) S DUR=$S(DUR["H":"H",1:"X")_+DUR
    101         S X=+VQTY_"&"_$E($P(VQTY," ",2))_U_$P($P(VQTY,"/",2)," ")_U_DUR
    102         S VAL=$$QUAN^FHWOR5R(PRD_"-"_STR,X)_U_VQTY
    103         Q
    104 FINDTYP(VAL,DGRP)             ; Return type of dietetics order based on display group
    105         S VAL=$P($G(^ORD(100.98,DGRP,0)),U,3)
    106         S:VAL="D AO" VAL="A" S VAL=$E(VAL)
    107         Q
    108 ISOIEN(VAL)         ; Return IEN for the Isolation/Precaution orderable item
    109         S VAL=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0))
    110         Q
    111 CURISO(VAL,ORVP)        ; Return a patient's current isolation
    112         S ORVP=ORVP_";DPT(" S VAL=$P($$IP^ORMBLD,U,2)
    113         I '$L(VAL) S VAL="<none>"
    114         Q
    115 ISOLIST(LST)       ; Return list of active isolations/precautions
    116         N I,X,IEN
    117         S I=0,X="" F  S X=$O(^FH(119.4,"B",X)) Q:X=""  S IEN=$O(^(X,0)) D
    118         . I '$D(^FH(119.4,IEN,"I")) S I=I+1,LST(I)=IEN_U_X
    119         Q
    120 MILTM(X)               ; return military time for am/pm time
    121         N TM
    122         S TM=$P(X,":",1)_+$P(X,":",2)
    123         I X["P",TM<1200 S TM=TM+1200
    124         I X["A",TM>1200 S TM=TM-1200
    125         Q TM
    126         ;
    127 ASKLATE(REC,DFN,ORIFN)         ; Return info for ordering late tray for diet order
    128         ; REC=0  or  1^meal^bagged^time^time^time
    129         S REC=0 Q:'$G(ORIFN)  Q:$E($$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E"),1,3)="NPO"
    130         N X,Y,%DT,STRT,DATE,ORPARAM,I,MEAL,MEALTIME
    131         S X=$O(^OR(100,ORIFN,4.5,"ID","START",0)),X=$G(^OR(100,ORIFN,4.5,+X,1))
    132         Q:X=""  S %DT="TX" D ^%DT Q:Y'>0  Q:$P(Y,".")>DT  ;invalid or future
    133         S DATE=$P(Y,"."),STRT=+$E($P(Y,".",2)_"0000",1,4),MEAL=0
    134         D EN^FHWOR8(DFN,.ORPARAM) Q:'$D(ORPARAM(2))
    135         F I=1,3,5 I $P(ORPARAM(2),U,I)<STRT,STRT<$P(ORPARAM(2),U,I+1) S MEAL=I Q
    136         S MEAL=$S(MEAL=1:4,MEAL=3:10,MEAL=5:16,1:0) Q:'MEAL
    137         S MEALTIME=$P(ORPARAM(1),U,MEAL,MEAL+2)
    138         S MEAL=$S(MEAL=4:"B",MEAL=10:"N",MEAL=16:"E",1:"")
    139         F I=1:1:3 S X=$$MILTM($P(MEAL,U,I)) I X<STRT S $P(MEAL,U,I)=""
    140         S REC="1"_U_MEAL_U_$P(ORPARAM(2),U,10)_U_MEALTIME
    141         I $P(REC,U,2,4)="^^" S REC=0
    142         Q
    143 ADDLATE(REC,ORVP,ORNP,ORL,MEAL,TIME,BAG)             ; Add late tray order
    144         N ORIFN,ORNEW,ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORCHECK,ORLOG
    145         N ORDIALOG,ORDG,ORTYPE,DA,FIRST,TRAY
    146         S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
    147         S ORTYPE="D",FIRST=1,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
    148         S TRAY=+$O(^ORD(101.43,"S.E/L T","LATE TRAY",0))
    149         S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0))
    150         D GETDLG^ORCD(ORDIALOG)
    151         S ORDIALOG($$PTR^ORCD("OR GTX MEAL"),1)=MEAL
    152         S ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)=TRAY
    153         S ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1)=DT
    154         S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE"),1)=DT
    155         S ORDIALOG($$PTR^ORCD("OR GTX MEAL TIME"),1)=TIME
    156         S ORDIALOG($$PTR^ORCD("OR GTX YES/NO"),1)=BAG
    157         D EN^ORCSAVE
    158         S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
    159         Q
    160 CURMEALS(ORY,ORDFN,ORMEAL)          ;Return current list of recurring meals for AO and TF orders
    161         N I,Y,X S I=0
    162         S ORMEAL=$G(ORMEAL,"")
    163         D EN2^FHWOR8(ORDFN,ORMEAL,.ORY)
    164         F  S I=$O(ORY(I)) Q:'I  D
    165         . S X=$P(ORY(I),U,2)
    166         . S Y=$P(ORY(I),U,1) D DD^%DT S $P(ORY(I),U,2)=Y
    167         . S $P(ORY(I),U,3)=$S(X="B":"Breakfast",X="N":"Noon",X="E":"Evening",1:"")
    168         Q
    169 NFSLOC(ORLOC)   ;Get NUTRITION LOCATION name for HOSPITAL LOCATION
    170         Q $$NFSLOC^FHOMAPI(ORLOC)
    171 OPLOCOK(ORY,ORLOC)      ; OK to order OP Meals from this location
    172         I 'ORLOC S ORY=0 Q
    173         S ORY=$S($L($$NFSLOC^FHOMAPI(ORLOC))>0:1,1:0)
    174         Q
     1ORWDFH ; SLC/KCM/JLI - Diet Order calls for Windows Dialogs ;12/12/00  14:44
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,141,187,215**;Dec 17, 1997
     3TXT(LST,DFN)    ; Return text of current & future diets for a patient
     4 S LST(1)="Current Diet:  "_$$DIET^ORCDFH(DFN)
     5 N FUTLST D FUT(.FUTLST,DFN) I $D(FUTLST)>1 D
     6 . S LST(2)="Future Diet Orders:",ILST=2
     7 . S I=0 F  S I=$O(FUTLST(I)) Q:'I  D
     8 . . S X=$$FMTE^XLFDT(I,2)_"  "_$P(FUTLST(I),U,2)
     9 . . S LST(ILST)=$S(ILST=2:"Future Diet Orders:  "_X,1:"   "_X)
     10 . . S ILST=ILST+1
     11 Q
     12FUT(LST,DFN)    ; Return a list of future diet orders
     13 N DGRP,NXTDT,ORIFN,ORVP,ORTX
     14 S ORVP=DFN_";DPT(",DGRP=$O(^ORD(100.98,"B","DO",0)),NXTDT=$$NOW^XLFDT
     15 F  S NXTDT=$O(^OR(100,"AW",ORVP,DGRP,NXTDT)) Q:NXTDT'>0  D
     16 . S ORIFN=+$O(^OR(100,"AW",ORVP,DGRP,NXTDT,0))
     17 . I $P($G(^OR(100,ORIFN,3)),U,3)'=8 Q  ; only scheduled diets
     18 . D TEXT^ORQ12(.ORTX,ORIFN) S LST(NXTDT)=NXTDT_U_$G(ORTX(1))
     19 Q
     20PARAM(ORLST,ORVP,ORLOC)  ; Return dietetics parameters for a patient at a location
     21 ; ORLOC: hospital location ptr to ^SC #44
     22 ; ORLST(1)=EB1^EB2^EB3^LB1^LB2^LB3^EN1^EN2^...LE2^LE3
     23 ; ORLST(2)=BAB^BAE^NAB^NAE^EAB^EAE^BegB^BegN^BegE^Bagged
     24 ; ORLST(3)=type of service^RegIEN^NPOIEN^EarlyIEN^LateIEN^TFIFN
     25 ; ORLST(4)=max days in future for outpatient recurring meals
     26 ; ORLST(5)=default outpatient diet
     27 Q:'+ORVP
     28 N X,IEN,CURTM
     29 S ORVP=+ORVP_";DPT(",ORLOC=+ORLOC
     30 S CURTM=$$NOW^XLFDT
     31 I $D(^SC(ORLOC,42)) S ORLOC=$G(^SC(ORLOC,42))_";DIC(42"
     32 E  S ORLOC=ORLOC_";SC("
     33 D EN1^FHWOR8(ORLOC,.ORLST)
     34 ;
     35 I '$L($G(ORLST(3))) S ORLST(3)="T"
     36 S $P(ORLST(3),U,2)=$O(^ORD(101.43,"S.DIET","REGULAR",0))
     37 S $P(ORLST(3),U,3)=$O(^ORD(101.43,"S.DIET","NPO",0))
     38 S $P(ORLST(3),U,4)=$O(^ORD(101.43,"S.E/L T","EARLY TRAY",0))
     39 S $P(ORLST(3),U,5)=$O(^ORD(101.43,"S.E/L T","LATE TRAY",0))
     40 N TF S TF=$$CURRENT^ORCDFH("TF") I $L(TF,";")=1 S TF=TF_";1"
     41 I TF,'$$FUTURE^ORCDFH("EFFECTIVE DATE/TIME") S $P(ORLST(3),U,6)=TF
     42 I $$VERSION^XPDUTL("FH")>5 D
     43 . S ORLST(4)=$$MAXDAYS^FHOMAPI(ORLOC)
     44 . D DIETLST^FHOMAPI Q:'$G(FHDIET(1))
     45 . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(1),U,1)_";99FHD",0)) Q:+IEN=0
     46 . S X=^ORD(101.43,"S.DIET",$P(FHDIET(1),U,2),IEN)
     47 . I +$P(X,U,3),$P(X,U,3)<CURTM Q
     48 . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q
     49 . S ORLST(5)=+$G(IEN)
     50 Q
     51ATTR(REC,OI)    ; Return OI^Text^Type^Precedence^AskExpire for a diet
     52 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT S REC="0^"_$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." Q
     53 S REC=OI_U_$P($G(^ORD(101.43,OI,0)),U)_U_$G(^("FH"))
     54 Q
     55DIETS(Y,FROM,DIR)       ; Return a subset of active diets, including NPO
     56 ; Y(n)=IEN^.01 Name^.01 Name  -or-  IEN^Synonym <.01 Name>^.01 Name
     57 N I,IEN,CNT,X,CURTM
     58 S I=0,CNT=44,CURTM=$$NOW^XLFDT
     59 F  Q:I'<CNT  S FROM=$O(^ORD(101.43,"S.DIET",FROM),DIR) Q:FROM=""  D
     60 . S IEN=0 F  S IEN=$O(^ORD(101.43,"S.DIET",FROM,IEN)) Q:'IEN  D
     61 . . S X=^ORD(101.43,"S.DIET",FROM,IEN)
     62 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
     63 . . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q
     64 . . S I=I+1
     65 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
     66 . . E  S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
     67 Q
     68OPDIETS(ORY,FROM,DIR)   ;Return a list of up to 5 outpatient diets from file 119.9
     69 N X,I,J,IEN,CURTM,SYNCNT,SYNTOT,FHDIET
     70 D DIETLST^FHOMAPI
     71 S CURTM=$$NOW^XLFDT,I=0,SYNTOT=1
     72 F  S I=$O(FHDIET(I)) Q:'I  D
     73 . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(I),U,1)_";99FHD",0)) Q:+IEN=0
     74 . S X=^ORD(101.43,"S.DIET",$P(FHDIET(I),U,2),IEN)
     75 . I +$P(X,U,3),$P(X,U,3)<CURTM Q
     76 . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q
     77 . S X=$P(^ORD(101.43,IEN,0),U,1)
     78 . S SYNCNT=$P($G(^ORD(101.43,IEN,2,0)),U,4),J=0
     79 . S ORY(X)=IEN_U_X_U_X
     80 . I +SYNCNT  D  Q
     81 . . S SYNTOT=SYNTOT+SYNCNT
     82 . . F  S J=$O(^ORD(101.43,IEN,2,J)) Q:'J  D
     83 . . . S ORY(^ORD(101.43,IEN,2,J,0))=IEN_U_^ORD(101.43,IEN,2,J,0)_$C(9)_"<"_X_">"_U_X
     84 Q
     85TFPROD(Y)     ; Return a list of active tubefeeding products
     86 N I,IEN,NAM,X,CURTM
     87 S I=0,NAM="",CURTM=$$NOW^XLFDT
     88 F  S NAM=$O(^ORD(101.43,"S.TF",NAM)) Q:NAM=""  D
     89 . S IEN=0 F  S IEN=$O(^ORD(101.43,"S.TF",NAM,IEN)) Q:'IEN  D
     90 . . S X=^ORD(101.43,"S.TF",NAM,IEN)
     91 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
     92 . . S I=I+1
     93 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
     94 . . E  S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
     95 Q
     96QTY2CC(VAL,PRD,STR,QTY)     ; Return cc's given a product, strength, & quantity
     97 N X,VQTY,DUR
     98 S VQTY=$$VALIDQTY^ORCDFHTF(QTY) I '$L(VQTY)!('PRD)!('STR) S VAL="" Q
     99 S PRD=+$P($G(^ORD(101.43,PRD,0)),U,2)
     100 S DUR=$P(VQTY," X ",2) I $L(DUR) S DUR=$S(DUR["H":"H",1:"X")_+DUR
     101 S X=+VQTY_"&"_$E($P(VQTY," ",2))_U_$P($P(VQTY,"/",2)," ")_U_DUR
     102 S VAL=$$QUAN^FHWOR5R(PRD_"-"_STR,X)_U_VQTY
     103 Q
     104FINDTYP(VAL,DGRP)       ; Return type of dietetics order based on display group
     105 S VAL=$P($G(^ORD(100.98,DGRP,0)),U,3)
     106 S:VAL="D AO" VAL="A" S VAL=$E(VAL)
     107 Q
     108ISOIEN(VAL)     ; Return IEN for the Isolation/Precaution orderable item
     109 S VAL=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0))
     110 Q
     111CURISO(VAL,ORVP) ; Return a patient's current isolation
     112 S ORVP=ORVP_";DPT(" S VAL=$P($$IP^ORMBLD,U,2)
     113 I '$L(VAL) S VAL="<none>"
     114 Q
     115ISOLIST(LST)    ; Return list of active isolations/precautions
     116 N I,X,IEN
     117 S I=0,X="" F  S X=$O(^FH(119.4,"B",X)) Q:X=""  S IEN=$O(^(X,0)) D
     118 . I '$D(^FH(119.4,IEN,"I")) S I=I+1,LST(I)=IEN_U_X
     119 Q
     120MILTM(X)        ; return military time for am/pm time
     121 N TM
     122 S TM=$P(X,":",1)_+$P(X,":",2)
     123 I X["P",TM<1200 S TM=TM+1200
     124 I X["A",TM>1200 S TM=TM-1200
     125 Q TM
     126 ;
     127ASKLATE(REC,DFN,ORIFN)        ; Return info for ordering late tray for diet order
     128 ; REC=0  or  1^meal^bagged^time^time^time
     129 S REC=0 Q:'$G(ORIFN)  Q:$E($$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E"),1,3)="NPO"
     130 N X,Y,%DT,STRT,DATE,ORPARAM,I,MEAL,MEALTIME
     131 S X=$O(^OR(100,ORIFN,4.5,"ID","START",0)),X=$G(^OR(100,ORIFN,4.5,+X,1))
     132 Q:X=""  S %DT="TX" D ^%DT Q:Y'>0  Q:$P(Y,".")>DT  ;invalid or future
     133 S DATE=$P(Y,"."),STRT=+$E($P(Y,".",2)_"0000",1,4),MEAL=0
     134 D EN^FHWOR8(DFN,.ORPARAM) Q:'$D(ORPARAM(2))
     135 F I=1,3,5 I $P(ORPARAM(2),U,I)<STRT,STRT<$P(ORPARAM(2),U,I+1) S MEAL=I Q
     136 S MEAL=$S(MEAL=1:4,MEAL=3:10,MEAL=5:16,1:0) Q:'MEAL
     137 S MEALTIME=$P(ORPARAM(1),U,MEAL,MEAL+2)
     138 S MEAL=$S(MEAL=4:"B",MEAL=10:"N",MEAL=16:"E",1:"")
     139 F I=1:1:3 S X=$$MILTM($P(MEAL,U,I)) I X<STRT S $P(MEAL,U,I)=""
     140 S REC="1"_U_MEAL_U_$P(ORPARAM(2),U,10)_U_MEALTIME
     141 I $P(REC,U,2,4)="^^" S REC=0
     142 Q
     143ADDLATE(REC,ORVP,ORNP,ORL,MEAL,TIME,BAG)      ; Add late tray order
     144 N ORIFN,ORNEW,ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORCHECK,ORLOG
     145 N ORDIALOG,ORDG,ORTYPE,DA,FIRST,TRAY
     146 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
     147 S ORTYPE="D",FIRST=1,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
     148 S TRAY=+$O(^ORD(101.43,"S.E/L T","LATE TRAY",0))
     149 S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0))
     150 D GETDLG^ORCD(ORDIALOG)
     151 S ORDIALOG($$PTR^ORCD("OR GTX MEAL"),1)=MEAL
     152 S ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)=TRAY
     153 S ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1)=DT
     154 S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE"),1)=DT
     155 S ORDIALOG($$PTR^ORCD("OR GTX MEAL TIME"),1)=TIME
     156 S ORDIALOG($$PTR^ORCD("OR GTX YES/NO"),1)=BAG
     157 D EN^ORCSAVE
     158 S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
     159 Q
     160CURMEALS(ORY,ORDFN,ORMEAL)     ;Return current list of recurring meals for AO and TF orders
     161 N I,Y,X S I=0
     162 S ORMEAL=$G(ORMEAL,"")
     163 D EN2^FHWOR8(ORDFN,ORMEAL,.ORY)
     164 F  S I=$O(ORY(I)) Q:'I  D
     165 . S X=$P(ORY(I),U,2)
     166 . S Y=$P(ORY(I),U,1) D DD^%DT S $P(ORY(I),U,2)=Y
     167 . S $P(ORY(I),U,3)=$S(X="B":"Breakfast",X="N":"Noon",X="E":"Evening",1:"")
     168 Q
     169NFSLOC(ORLOC) ;Get NUTRITION LOCATION name for HOSPITAL LOCATION
     170 Q $$NFSLOC^FHOMAPI(ORLOC)
     171OPLOCOK(ORY,ORLOC) ; OK to order OP Meals from this location
     172 I 'ORLOC S ORY=0 Q
     173 S ORY=$S($L($$NFSLOC^FHOMAPI(ORLOC))>0:1,1:0)
     174 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDGX.m

    r613 r623  
    1 ORWDGX  ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96  8:21 AM ]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
    3         ;
    4 ACT()   N X,RSLT S X=^(0),RSLT=1
    5         I "DQ"'[$P(X,U,4) S RSLT=0
    6         S X1=$O(^ORD(100.98,"B","ACTIVITY",0))
    7         S X2=$O(^ORD(100.98,"B","NURSING",0))
    8         I "DQ"'[$P(X,U,4) S RSLT=0
    9         I RSLT,((U_X1_U_X2_U)'[(U_$P(X,U,5)_U)) S RSLT=0
    10         Q RSLT
    11 NURS()  N X,RSLT S X=^(0),RSLT=1
    12         I "DQ"'[$P(X,U,4) S RSLT=0
    13         I RSLT,($P(X,U,5)'=$O(^ORD(100.98,"B","NURSING",0))) S RSLT=0
    14         Q RSLT
    15 OITEXT(Y,DLG)      ; Return Orderable Item Text given dialog or quick order
    16         S Y=$P(^ORD(101.41,DLG,0),U,2)
    17         Q
    18 LOAD(LST,PAR)            ; Load a list of activity orders
    19         N I,ILST,DLG,NAM,TLST
    20         D GETLST^XPAR(.TLST,"ALL",PAR)
    21         S I=0,ILST=0 F  S I=$O(TLST(I)) Q:'I  D
    22         . S DLG=$P(TLST(I),U,2),NAM=$P(^ORD(101.41,+DLG,0),U,2)
    23         . S ILST=ILST+1,LST(ILST)=DLG_U_NAM
    24         Q
    25         ;
    26         N DLGTYP,OIDLG,FTDLG,OITYP,I,IFN
    27         S DLGTYP=$P(^ORD(101.41,DLG,0),U,4)
    28         S OIDLG=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
    29         S FTDLG=$O(^ORD(101.41,"B","OR GTX FREE TEXT OI",0))
    30         I DLGTYP="D" D
    31         . S I=0,IFN=0 F  S I=$O(^ORD(101.41,DLG,10,I)) S X=^(I,0) D  Q:IFN
    32         . . I $P(X,U,2)=OIDLG S IFN=I,OITYP="O"
    33         . . I $P(X,U,2)=FTDLG S IFN=I,OITYP="F"
    34         . S Y="" I $L($G(^ORD(101.41,DLG,10,IFN,7))) X ^(7)
    35         . I OITYP="O" S Y=$P(^ORD(101.43,+Y,0),U,1)
    36         Q
    37 VMDEF(LST)              ; Return dialog definition for vitals/measurements
    38         N ILST S ILST=0
    39         S LST($$NXT)="~Measurements" D MEASURE
    40         S LST($$NXT)="~Schedules" D VMSCHED
    41         Q
    42 MEASURE ; Get measurements available
    43         S X="" F  S X=$O(^ORD(101.43,"S.V/M",X)) Q:X=""  D
    44         . S I=$O(^ORD(101.43,"S.V/M",X,0)),LST($$NXT)="i"_I_U_X
    45         S LST($$NXT)="dTPR B/P"      ; ** do this with a parameter
    46         Q
    47 VMSCHED ; Get vitals/measurements schedules
    48         K ^TMP($J,"ORWDGX APGMRV")
    49         D AP^PSS51P1("GMRV",,,,"ORWDGX APGMRV")
    50         S X="" F  S X=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X)) Q:X=""  D
    51         . S I=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X,0)),LST($$NXT)="i"_I_U_X
    52         K ^TMP($J,"ORWDGX APGMRV")
    53         Q
    54 NXT()   ; Increment index into LST
    55         S ILST=ILST+1
    56         Q ILST
     1ORWDGX ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96  8:21 AM ]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
     3 ;
     4ACT() N X,RSLT S X=^(0),RSLT=1
     5 I "DQ"'[$P(X,U,4) S RSLT=0
     6 S X1=$O(^ORD(100.98,"B","ACTIVITY",0))
     7 S X2=$O(^ORD(100.98,"B","NURSING",0))
     8 I "DQ"'[$P(X,U,4) S RSLT=0
     9 I RSLT,((U_X1_U_X2_U)'[(U_$P(X,U,5)_U)) S RSLT=0
     10 Q RSLT
     11NURS() N X,RSLT S X=^(0),RSLT=1
     12 I "DQ"'[$P(X,U,4) S RSLT=0
     13 I RSLT,($P(X,U,5)'=$O(^ORD(100.98,"B","NURSING",0))) S RSLT=0
     14 Q RSLT
     15OITEXT(Y,DLG)    ; Return Orderable Item Text given dialog or quick order
     16 S Y=$P(^ORD(101.41,DLG,0),U,2)
     17 Q
     18LOAD(LST,PAR)          ; Load a list of activity orders
     19 N I,ILST,DLG,NAM,TLST
     20 D GETLST^XPAR(.TLST,"ALL",PAR)
     21 S I=0,ILST=0 F  S I=$O(TLST(I)) Q:'I  D
     22 . S DLG=$P(TLST(I),U,2),NAM=$P(^ORD(101.41,+DLG,0),U,2)
     23 . S ILST=ILST+1,LST(ILST)=DLG_U_NAM
     24 Q
     25 ;
     26 N DLGTYP,OIDLG,FTDLG,OITYP,I,IFN
     27 S DLGTYP=$P(^ORD(101.41,DLG,0),U,4)
     28 S OIDLG=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
     29 S FTDLG=$O(^ORD(101.41,"B","OR GTX FREE TEXT OI",0))
     30 I DLGTYP="D" D
     31 . S I=0,IFN=0 F  S I=$O(^ORD(101.41,DLG,10,I)) S X=^(I,0) D  Q:IFN
     32 . . I $P(X,U,2)=OIDLG S IFN=I,OITYP="O"
     33 . . I $P(X,U,2)=FTDLG S IFN=I,OITYP="F"
     34 . S Y="" I $L($G(^ORD(101.41,DLG,10,IFN,7))) X ^(7)
     35 . I OITYP="O" S Y=$P(^ORD(101.43,+Y,0),U,1)
     36 Q
     37VMDEF(LST)         ; Return dialog definition for vitals/measurements
     38 N ILST S ILST=0
     39 S LST($$NXT)="~Measurements" D MEASURE
     40 S LST($$NXT)="~Schedules" D VMSCHED
     41 Q
     42MEASURE ; Get measurements available
     43 S X="" F  S X=$O(^ORD(101.43,"S.V/M",X)) Q:X=""  D
     44 . S I=$O(^ORD(101.43,"S.V/M",X,0)),LST($$NXT)="i"_I_U_X
     45 S LST($$NXT)="dTPR B/P"      ; ** do this with a parameter
     46 Q
     47VMSCHED ; Get vitals/measurements schedules
     48 S X="" F  S X=$O(^PS(51.1,"APGMRV",X)) Q:X=""  D
     49 . S I=$O(^PS(51.1,"APGMRV",X,0)),LST($$NXT)="i"_I_U_X
     50 Q
     51NXT() ; Increment index into LST
     52 S ILST=ILST+1
     53 Q ILST

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m

    r613 r623  
    1 ORWDLR  ; SLC/KCM - Lab Calls [ 08/04/96  8:47 PM ]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
    3         ;
    4 DEF(LST,ALOC)   ; procedure
    5         ; get dialog definition specific to lab
    6         S ILST=0
    7         S LST($$NXT)="~Collection Times" D COLLTM
    8         S LST($$NXT)="~Send Patient Times" D SENDTM
    9         S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3
    10         ; S LST($$NXT)="~Urgencies Map" D URGMAP
    11         S LST($$NXT)="~Schedules" D SCHED
    12         S LST($$NXT)="~Common" D COMMON
    13         Q
    14 COLLTM  ; get collection times
    15         N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT
    16         S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H
    17         M TMRW=TDAY D INCDATE(.TMRW)
    18         I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
    19         . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
    20         . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
    21         . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
    22         . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
    23         . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
    24         . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
    25         . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
    26         . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
    27         . S CNT=0 F  Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0))))  D  Q:CNT>6
    28         . . D INCDATE(.TDAY) S CNT=CNT+1
    29         . S CNT=0 F  Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0))))  D  Q:CNT>6
    30         . . D INCDATE(.TMRW) S CNT=CNT+1
    31         D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
    32         S ICTM=0 F  S ICTM=$O(CTM(ICTM)) Q:'ICTM  D
    33         . I $P(CTM(ICTM),U)>$P($H,",",2) D
    34         . . S FMDT=TDAY
    35         . . I +TDAY("H")=+$H S DAY="Today"
    36         . . I TDAY("H")-$H=1 S DAY="Tomorrow"
    37         . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
    38         . E  D
    39         . . S FMDT=TMRW
    40         . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
    41         . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM")
    42         . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2)
    43         . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
    44         . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
    45         D NOW^%DTC
    46         S LST($$NXT)="iW"_%_"^Now (Collect on ward)"
    47         Q
    48 SENDTM  ; get send patient times
    49         N X,X1,X2
    50         S LST($$NXT)="iL"_DT_"^Today"
    51         S X1=DT,X2=1 D C^%DTC
    52         S LST($$NXT)="iL"_X_"^Tomorrow"
    53         Q
    54 INCDATE(ADATE)  ; called from COLLTM, increments date nodes in .ADATE
    55         N X,X1,X2,%H
    56         S X1=ADATE,X2=1 D C^%DTC S ADATE=X
    57         S ADATE("H")=ADATE("H")+1
    58         S ADATE("DOW")=ADATE("H")#7
    59         Q
    60 DOWNAME(DOW)    ; function
    61         ; Returns Day of Week name (DOW should be $H#7)
    62         I DOW=0 Q "Thursday"
    63         I DOW=1 Q "Friday"
    64         I DOW=2 Q "Saturday"
    65         I DOW=3 Q "Sunday"
    66         I DOW=4 Q "Monday"
    67         I DOW=5 Q "Tuesday"
    68         I DOW=6 Q "Wednesday"
    69         Q ""
    70 URGMAP  ; return list of lab urgencies mapped to OE/RR urgencies
    71         Q
    72         N I,X
    73         S I=0 F  S I=$O(^LAB(62.05,I)) Q:'I  S X=^(I,0) I '$P(X,U,3) D
    74         . S LST($$NXT)="i"_I_"="_I_U_$P(X,U)
    75         ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N")
    76         ; S URG=0 F  S URG=$O(Y(URG)) Q:'URG  S LST($$NXT)="i"_URG_"="_Y(URG)
    77         Q
    78 SCHED   ; return list of schedules available for lab tests
    79         N X,IEN
    80         K ^TMP($J,"ORWDLR APLR")
    81         D AP^PSS51P1("LR",,,,"ORWDLR APLR")
    82         S X="" F  S X=$O(^TMP($J,"ORWDLR APLR","APLR",X)) Q:X=""  D
    83         . S IEN=$O(^TMP($J,"ORWDLR APLR","APLR",X,"")) I IEN'>0 Q
    84         . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^TMP($J,"ORWDLR APLR",IEN,5)),U)
    85         . I X="ONE TIME" S LST($$NXT)="d"_X
    86         K ^TMP($J,"ORWDLR APLR")
    87         Q
    88 COMMON  ; return list of commonly ordered lab tests
    89         N TMPLST,IEN,I
    90         D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT")
    91         S I=0 F  S I=$O(TMPLST(I)) Q:'I  D
    92         . S IEN=$P(TMPLST(I),U,2)
    93         . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
    94         Q
    95 LOAD(LST,TESTID)        ; procedure
    96         ; Return sample, specimen, & urgency info about a lab test
    97         N X,Y,ILST,PARAM S ILST=0
    98         S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1)
    99         I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
    100         S I=0 F  S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I  S LST($$NXT)="t"_^(I,0)
    101         S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
    102         D TEST^LR7OR3(TESTID,.Y)
    103         S PARAM="" F  S PARAM=$O(Y(PARAM)) Q:PARAM=""  D
    104         . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM)))
    105         . I $D(Y(PARAM))>1 S I=0 F  S I=$O(Y(PARAM,I)) Q:'I  D
    106         . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q
    107         . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q
    108         . . S LST($$NXT)="i"_I_U_Y(PARAM,I)
    109         . . I PARAM="CollSamp" D
    110         . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1
    111         . . . S X=+$P(Y(PARAM,I),U,3)
    112         . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
    113         . . I $D(Y(PARAM,I,"WP")) S J=0 F  S J=$O(Y(PARAM,I,"WP",J)) Q:'J  D
    114         . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0)
    115         Q
    116 ALLSAMP(LST)    ; procedure
    117         ; returns all collection samples
    118         ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
    119         N SMP,SPC,ILST,IEN,X,X0
    120         S ILST=0,LST($$NXT)="~CollSamp"
    121         S SMP="" F  S SMP=$O(^LAB(62,"B",SMP)) Q:SMP=""  D
    122         . S IEN=0 F  S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN  D
    123         . . S X0=^LAB(62,IEN,0)
    124         . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
    125         . . I $P(X0,U,2) D
    126         . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
    127         . . . S SPC($P(X,U,4))=$P(X,U,10)
    128         . . S LST($$NXT)=X
    129         S LST($$NXT)="~Specimens"
    130         S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
    131         Q
    132 ABBSPEC(LST)    ; procedure
    133         ; returns specimens with abbreviation (uses 'E' xref)
    134         N X,IEN,ILST S ILST=0
    135         S X="" F  S X=$O(^LAB(61,"E",X)) Q:X=""  S IEN=$O(^(X,0)) D
    136         . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
    137         Q
    138 NXT()   ; called by TESTINFO, increments ILST
    139         S ILST=ILST+1
    140         Q ILST
    141 STOP(VAL,X2)          ; return a calculated stop date
    142         N X1,X
    143         S X1=DT D C^%DTC S VAL=X
    144         Q
     1ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96  8:47 PM ]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
     3 ;
     4DEF(LST,ALOC) ; procedure
     5 ; get dialog definition specific to lab
     6 S ILST=0
     7 S LST($$NXT)="~Collection Times" D COLLTM
     8 S LST($$NXT)="~Send Patient Times" D SENDTM
     9 S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3
     10 ; S LST($$NXT)="~Urgencies Map" D URGMAP
     11 S LST($$NXT)="~Schedules" D SCHED
     12 S LST($$NXT)="~Common" D COMMON
     13 Q
     14COLLTM ; get collection times
     15 N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT
     16 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H
     17 M TMRW=TDAY D INCDATE(.TMRW)
     18 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
     19 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
     20 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
     21 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
     22 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
     23 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
     24 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
     25 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
     26 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
     27 . S CNT=0 F  Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0))))  D  Q:CNT>6
     28 . . D INCDATE(.TDAY) S CNT=CNT+1
     29 . S CNT=0 F  Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0))))  D  Q:CNT>6
     30 . . D INCDATE(.TMRW) S CNT=CNT+1
     31 D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
     32 S ICTM=0 F  S ICTM=$O(CTM(ICTM)) Q:'ICTM  D
     33 . I $P(CTM(ICTM),U)>$P($H,",",2) D
     34 . . S FMDT=TDAY
     35 . . I +TDAY("H")=+$H S DAY="Today"
     36 . . I TDAY("H")-$H=1 S DAY="Tomorrow"
     37 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
     38 . E  D
     39 . . S FMDT=TMRW
     40 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
     41 . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM")
     42 . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2)
     43 . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
     44 . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
     45 D NOW^%DTC
     46 S LST($$NXT)="iW"_%_"^Now (Collect on ward)"
     47 Q
     48SENDTM ; get send patient times
     49 N X,X1,X2
     50 S LST($$NXT)="iL"_DT_"^Today"
     51 S X1=DT,X2=1 D C^%DTC
     52 S LST($$NXT)="iL"_X_"^Tomorrow"
     53 Q
     54INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE
     55 N X,X1,X2,%H
     56 S X1=ADATE,X2=1 D C^%DTC S ADATE=X
     57 S ADATE("H")=ADATE("H")+1
     58 S ADATE("DOW")=ADATE("H")#7
     59 Q
     60DOWNAME(DOW) ; function
     61 ; Returns Day of Week name (DOW should be $H#7)
     62 I DOW=0 Q "Thursday"
     63 I DOW=1 Q "Friday"
     64 I DOW=2 Q "Saturday"
     65 I DOW=3 Q "Sunday"
     66 I DOW=4 Q "Monday"
     67 I DOW=5 Q "Tuesday"
     68 I DOW=6 Q "Wednesday"
     69 Q ""
     70URGMAP ; return list of lab urgencies mapped to OE/RR urgencies
     71 Q
     72 N I,X
     73 S I=0 F  S I=$O(^LAB(62.05,I)) Q:'I  S X=^(I,0) I '$P(X,U,3) D
     74 . S LST($$NXT)="i"_I_"="_I_U_$P(X,U)
     75 ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N")
     76 ; S URG=0 F  S URG=$O(Y(URG)) Q:'URG  S LST($$NXT)="i"_URG_"="_Y(URG)
     77 Q
     78SCHED ; return list of schedules available for lab tests
     79 N X,IEN
     80 S X="" F  S X=$O(^PS(51.1,"APLR",X)) Q:X=""  S IEN=$O(^(X,0)) I IEN D
     81 . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^PS(51.1,IEN,0)),U,5)
     82 . I X="ONE TIME" S LST($$NXT)="d"_X
     83 Q
     84COMMON ; return list of commonly ordered lab tests
     85 N TMPLST,IEN,I
     86 D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT")
     87 S I=0 F  S I=$O(TMPLST(I)) Q:'I  D
     88 . S IEN=$P(TMPLST(I),U,2)
     89 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
     90 Q
     91LOAD(LST,TESTID) ; procedure
     92 ; Return sample, specimen, & urgency info about a lab test
     93 N X,Y,ILST,PARAM S ILST=0
     94 S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1)
     95 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
     96 S I=0 F  S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I  S LST($$NXT)="t"_^(I,0)
     97 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
     98 D TEST^LR7OR3(TESTID,.Y)
     99 S PARAM="" F  S PARAM=$O(Y(PARAM)) Q:PARAM=""  D
     100 . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM)))
     101 . I $D(Y(PARAM))>1 S I=0 F  S I=$O(Y(PARAM,I)) Q:'I  D
     102 . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q
     103 . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q
     104 . . S LST($$NXT)="i"_I_U_Y(PARAM,I)
     105 . . I PARAM="CollSamp" D
     106 . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1
     107 . . . S X=+$P(Y(PARAM,I),U,3)
     108 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
     109 . . I $D(Y(PARAM,I,"WP")) S J=0 F  S J=$O(Y(PARAM,I,"WP",J)) Q:'J  D
     110 . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0)
     111 Q
     112ALLSAMP(LST) ; procedure
     113 ; returns all collection samples
     114 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
     115 N SMP,SPC,ILST,IEN,X,X0
     116 S ILST=0,LST($$NXT)="~CollSamp"
     117 S SMP="" F  S SMP=$O(^LAB(62,"B",SMP)) Q:SMP=""  D
     118 . S IEN=0 F  S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN  D
     119 . . S X0=^LAB(62,IEN,0)
     120 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
     121 . . I $P(X0,U,2) D
     122 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
     123 . . . S SPC($P(X,U,4))=$P(X,U,10)
     124 . . S LST($$NXT)=X
     125 S LST($$NXT)="~Specimens"
     126 S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
     127 Q
     128ABBSPEC(LST) ; procedure
     129 ; returns specimens with abbreviation (uses 'E' xref)
     130 N X,IEN,ILST S ILST=0
     131 S X="" F  S X=$O(^LAB(61,"E",X)) Q:X=""  S IEN=$O(^(X,0)) D
     132 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
     133 Q
     134NXT() ; called by TESTINFO, increments ILST
     135 S ILST=ILST+1
     136 Q ILST
     137STOP(VAL,X2)       ; return a calculated stop date
     138 N X1,X
     139 S X1=DT D C^%DTC S VAL=X
     140 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m

    r613 r623  
    1 ORWDLR32        ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 2263   GETLST^XPAR  ^TMP($J,"WC")
    5         ;
    6 DEF(LST,ALOC,ADIV)      ; procedure
    7         ; For Event Delay Order
    8         ;  ALOC: Delay Event's default location
    9         ;  ADIV: Delay Event's default division
    10         ; get dialog definition specific to lab
    11         S ILST=0
    12         S LST($$NXT)="~ShortList" D SHORT
    13         S LST($$NXT)="~Lab Collection Times" D LCOLLTM
    14         S LST($$NXT)="~Ward Collection Times" D WCOLLTM
    15         S LST($$NXT)="~Send Patient Times" D SENDTM
    16         S LST($$NXT)="~Collection Types" D COLLTYP
    17         S LST($$NXT)="~Default Urgency" D URGENCY
    18         S LST($$NXT)="~Schedules" D SCHED
    19         S LST($$NXT)="~Common" D COMMON
    20         Q
    21 SHORT   ; from DEF, get short list of lab quick orders
    22         N I,ORTMP,ORDG,A
    23         S I=$O(^ORD(100.98,"B","LAB",0))  ; get IEN of parent lab
    24         D DG^ORCHANG1(I,"BILD",.ORDG)   ; find members groups for parent lab
    25         S I=0
    26         F  S I=$O(ORDG(I)) Q:'I  D   ; loop through list of members groups
    27         . I $E($P($G(^ORD(100.98,I,0)),"^",3),1,2)="VB" Q
    28         . D GETQLST^ORWDXQ(.ORTMP,I,"Q")   ;get quick order of each members groups
    29         . S A=0 F  S A=$O(ORTMP(A)) Q:'A  D   ; loop through returned quick orders and
    30         . . S LST($$NXT)="i"_ORTMP(A)  ; move quick orders to display list
    31         . K ORTMP   ; clean up for next members groups of quick orders
    32         Q
    33 LCOLLTM ; get collection times
    34         N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT
    35         S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T"
    36         M TMRW=TDAY D INCDATE(.TMRW)
    37         I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
    38         . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
    39         . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
    40         . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
    41         . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
    42         . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
    43         . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
    44         . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
    45         . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
    46         . S CNT=0 F  Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0))))  D  Q:CNT>6
    47         . . D INCDATE(.TDAY) S CNT=CNT+1
    48         . S CNT=0 F  Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0))))  D  Q:CNT>6
    49         . . D INCDATE(.TMRW) S CNT=CNT+1
    50         I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q")
    51         E  D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
    52         ;S DUZ(2)=TMPDIV
    53         S LST($$NXT)="iLNEXT^Next scheduled lab collection"
    54         S ICTM=0 F  S ICTM=$O(ORCTM(ICTM)) Q:'ICTM  D
    55         . I $P(ORCTM(ICTM),U)>$P($H,",",2) D
    56         . . S TXDT=TDAY("TX")
    57         . . I +TDAY("H")=+$H S DAY="Today"
    58         . . I TDAY("H")-$H=1 S DAY="Tomorrow"
    59         . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
    60         . E  D
    61         . . S TXDT=TMRW("TX")
    62         . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
    63         . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM")
    64         . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2)
    65         . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
    66         . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
    67         . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect"  ;DBIA 2263
    68         ; D NOW^%DTC
    69         ;S LST($$NXT)="iWNOW^Now (Collect on ward)"
    70         S LST($$NXT)="iLO^Future"
    71         Q
    72 WCOLLTM ; get Ward Collect times
    73         S I=""
    74         F  S I=$O(^TMP($J,"WC",I)) Q:I=""  D
    75         . S LST($$NXT)=^TMP($J,"WC",I)
    76         S LST($$NXT)="iWNOW^Now (Collect on ward)"
    77         ;S LST($$NXT)="iWO^Other"
    78         K ^TMP($J,"WC")
    79         Q
    80 SENDTM  ; get send patient times
    81         ;N X,X1,X2
    82         S LST($$NXT)="iLT^Today"
    83         ;S X1=DT,X2=1 D C^%DTC
    84         S LST($$NXT)="iLT+1^Tomorrow"
    85         ;S LST($$NXT)="iLO^Other"
    86         Q
    87 COLLTYP ; Collection Types in effect for this division
    88         N Y S Y=""
    89         S LST($$NXT)="iLC^Lab Collect"
    90         S LST($$NXT)="iWC^Ward Collect"
    91         S LST($$NXT)="iSP^Send Patient to Lab"
    92         I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect"
    93         S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK")
    94         I $L(Y) S LST($$NXT)="d"_Y
    95         Q
    96 INCDATE(ADATE)  ; called from COLLTM, increments date nodes in .ADATE
    97         N X,X1,X2,%H
    98         S X1=ADATE,X2=1 D C^%DTC S ADATE=X
    99         S ADATE("H")=ADATE("H")+1
    100         S ADATE("DOW")=ADATE("H")#7
    101         S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1)
    102         Q
    103 DOWNAME(DOW)    ; function
    104         ; Returns Day of Week name (DOW should be $H#7)
    105         I DOW=0 Q "Thursday"
    106         I DOW=1 Q "Friday"
    107         I DOW=2 Q "Saturday"
    108         I DOW=3 Q "Sunday"
    109         I DOW=4 Q "Monday"
    110         I DOW=5 Q "Tuesday"
    111         I DOW=6 Q "Wednesday"
    112         Q ""
    113 URGENCY ; return default urgency for lab
    114         N URG
    115         S URG=$$DEFURG^LR7OR3
    116         S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1)
    117         S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1)
    118         Q
    119 SCHED   ; return list of schedules available for lab tests
    120         N X,X0,IEN,TYPE,FREQ
    121         K ^TMP($J,"ORWDLR32 APLR")
    122         D AP^PSS51P1("LR",,,,"ORWDLR32 APLR")
    123         S X="" F  S X=$O(^TMP($J,"ORWDLR32 APLR","APLR",X)) Q:X=""  D
    124         .S IEN=$O(^TMP($J,"ORWDLR32 APLR","APLR",X,"")) I IEN'>0 Q
    125         .S TYPE=$P($G(^TMP($J,"ORWDLR32 APLR",IEN,5)),U)
    126         .S FREQ=+$G(^TMP($J,"ORWDLR32 APLR",IEN,2))
    127         .I ((TYPE="C")!(TYPE="D")),FREQ=0 Q
    128         .S LST($$NXT)="i"_IEN_U_X_U_TYPE_U_FREQ
    129         .I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X
    130         K ^TMP($J,"ORWDLR32 APLR")
    131         Q
    132 COMMON  ; return list of commonly ordered lab tests
    133         N ORLST,IEN,I
    134         D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT")  ;DBIA 2263
    135         S I=0 F  S I=$O(ORLST(I)) Q:'I  D
    136         . S IEN=$P(ORLST(I),U,2)
    137         . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
    138         Q
    139 LOAD(LST,TESTID)        ; procedure
    140         ; Return sample, specimen, & urgency info about a lab test
    141         N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM
    142         S ILST=0,X=$P(^ORD(101.43,TESTID,0),"^"),ORLABID=$P(^(0),U,2)
    143         S LST($$NXT)="~Test Name"
    144         S LST($$NXT)="d"_X
    145         S LST($$NXT)="~Item ID"
    146         S LST($$NXT)="d"_+ORLABID
    147         S X1=$S($P($P(^ORD(101.43,TESTID,0),U,2),";",2)="99VBC":$O(^LAB(60,"B",$P(^ORD(101.43,TESTID,0),"^")_" - LAB",0)),1:$P($P(^ORD(101.43,TESTID,0),U,2),";",1)) Q:'X1
    148         S X4=$P($G(^LAB(60,X1,0)),U,4)
    149         S LST(ILST)=LST(ILST)_U_X4
    150         I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
    151         S I=0 F  S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I  S LST($$NXT)="t"_^(I,0)
    152         S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
    153         D TEST^LR7OR3(X1,.ORY)
    154         S PARAM="" F  S PARAM=$O(ORY(PARAM)) Q:PARAM=""  D
    155         . S LST($$NXT)="~"_PARAM
    156         . I PARAM="ReqCom" D
    157         . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q
    158         . I PARAM="Default CollSamp" D
    159         . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q
    160         . I PARAM="Unique CollSamp" D
    161         . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q
    162         . I PARAM="Default Urgency" D
    163         . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q
    164         . I PARAM="Lab CollSamp" D
    165         . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q
    166         . I $D(ORY(PARAM))>1 S I=0 F  S I=$O(ORY(PARAM,I)) Q:'I  D
    167         . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q
    168         . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q
    169         . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q
    170         . . S LST($$NXT)="i"_I_U_ORY(PARAM,I)
    171         . . I PARAM="CollSamp" D
    172         . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1
    173         . . . S X=+$P(ORY(PARAM,I),U,3)
    174         . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
    175         . . I $D(ORY(PARAM,I,"WP")) S J=0 F  S J=$O(ORY(PARAM,I,"WP",J)) Q:'J  D
    176         . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0)
    177         Q
    178 ALLSAMP(LST)    ; procedure
    179         ; returns all collection samples
    180         ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
    181         N SMP,SPC,ILST,IEN,X,X0
    182         S ILST=0,LST($$NXT)="~CollSamp"
    183         S SMP="" F  S SMP=$O(^LAB(62,"B",SMP)) Q:SMP=""  D
    184         . S IEN=0 F  S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN  D
    185         . . S X0=^LAB(62,IEN,0)
    186         . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
    187         . . I $P(X0,U,2) D
    188         . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
    189         . . . S SPC($P(X,U,4))=$P(X,U,10)
    190         . . S LST($$NXT)=X
    191         S LST($$NXT)="~Specimens"
    192         S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
    193         Q
    194 ONESAMP(LST,IEN)        ;Return data for one colelction sample
    195         ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
    196         N SPC,ILST,X,X0
    197         Q:+$G(IEN)=0
    198         S ILST=0,LST($$NXT)="~CollSamp"
    199         S X0=^LAB(62,IEN,0)
    200         S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
    201         I $P(X0,U,2) D
    202         . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
    203         . S SPC($P(X,U,4))=$P(X,U,10)
    204         S LST($$NXT)=X
    205         S LST($$NXT)="~Specimens"
    206         S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
    207         Q
    208 ONESPEC(LST,IEN)        ;return one specimen
    209         Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0)))
    210         S LST=IEN_U_$P(^LAB(61,IEN,0),U,1)
    211         Q
    212 ABBSPEC(LST)    ; procedure
    213         ; returns specimens with abbreviation (uses 'E' xref)
    214         N X,IEN,ILST S ILST=0
    215         S X="" F  S X=$O(^LAB(61,"E",X)) Q:X=""  S IEN=$O(^(X,0)) D
    216         . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
    217         Q
    218 NXT()   ; called by TESTINFO, increments ILST
    219         S ILST=ILST+1
    220         Q ILST
    221         ;
     1ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250**;Dec 17, 1997;Build 1
     3 ;
     4 ; DBIA 2263   GETLST^XPAR  ^TMP($J,"WC")
     5 ;
     6DEF(LST,ALOC,ADIV) ; procedure
     7 ; For Event Delay Order
     8 ;  ALOC: Delay Event's default location
     9 ;  ADIV: Delay Event's default division
     10 ; get dialog definition specific to lab
     11 S ILST=0
     12 S LST($$NXT)="~ShortList" D SHORT
     13 S LST($$NXT)="~Lab Collection Times" D LCOLLTM
     14 S LST($$NXT)="~Ward Collection Times" D WCOLLTM
     15 S LST($$NXT)="~Send Patient Times" D SENDTM
     16 S LST($$NXT)="~Collection Types" D COLLTYP
     17 S LST($$NXT)="~Default Urgency" D URGENCY
     18 S LST($$NXT)="~Schedules" D SCHED
     19 S LST($$NXT)="~Common" D COMMON
     20 Q
     21SHORT ; from DEF, get short list of lab quick orders
     22 N I,ORTMP,ORDG,A
     23 S I=$O(^ORD(100.98,"B","LAB",0))  ; get IEN of parent lab
     24 D DG^ORCHANG1(I,"BILD",.ORDG)   ; find members groups for parent lab
     25 S I=0
     26 F  S I=$O(ORDG(I)) Q:'I  D   ; loop through list of members groups
     27 . D GETQLST^ORWDXQ(.ORTMP,I,"Q")   ;get quick order of each members groups
     28 . S A=0 F  S A=$O(ORTMP(A)) Q:'A  D   ; loop through returned quick orders and
     29 . . S LST($$NXT)="i"_ORTMP(A)  ; move quick orders to display list
     30 . K ORTMP   ; clean up for next members groups of quick orders
     31 Q
     32LCOLLTM ; get collection times
     33 N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT
     34 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T"
     35 M TMRW=TDAY D INCDATE(.TMRW)
     36 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
     37 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
     38 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
     39 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
     40 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
     41 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
     42 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
     43 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
     44 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
     45 . S CNT=0 F  Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0))))  D  Q:CNT>6
     46 . . D INCDATE(.TDAY) S CNT=CNT+1
     47 . S CNT=0 F  Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0))))  D  Q:CNT>6
     48 . . D INCDATE(.TMRW) S CNT=CNT+1
     49 I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q")
     50 E  D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
     51 ;S DUZ(2)=TMPDIV
     52 S LST($$NXT)="iLNEXT^Next scheduled lab collection"
     53 S ICTM=0 F  S ICTM=$O(ORCTM(ICTM)) Q:'ICTM  D
     54 . I $P(ORCTM(ICTM),U)>$P($H,",",2) D
     55 . . S TXDT=TDAY("TX")
     56 . . I +TDAY("H")=+$H S DAY="Today"
     57 . . I TDAY("H")-$H=1 S DAY="Tomorrow"
     58 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
     59 . E  D
     60 . . S TXDT=TMRW("TX")
     61 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
     62 . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM")
     63 . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2)
     64 . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
     65 . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
     66 . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect"  ;DBIA 2263
     67 ; D NOW^%DTC
     68 ;S LST($$NXT)="iWNOW^Now (Collect on ward)"
     69 S LST($$NXT)="iLO^Future"
     70 Q
     71WCOLLTM ; get Ward Collect times
     72 S I=""
     73 F  S I=$O(^TMP($J,"WC",I)) Q:I=""  D
     74 . S LST($$NXT)=^TMP($J,"WC",I)
     75 S LST($$NXT)="iWNOW^Now (Collect on ward)"
     76 ;S LST($$NXT)="iWO^Other"
     77 K ^TMP($J,"WC")
     78 Q
     79SENDTM ; get send patient times
     80 ;N X,X1,X2
     81 S LST($$NXT)="iLT^Today"
     82 ;S X1=DT,X2=1 D C^%DTC
     83 S LST($$NXT)="iLT+1^Tomorrow"
     84 ;S LST($$NXT)="iLO^Other"
     85 Q
     86COLLTYP ; Collection Types in effect for this division
     87 N Y S Y=""
     88 S LST($$NXT)="iLC^Lab Collect"
     89 S LST($$NXT)="iWC^Ward Collect"
     90 S LST($$NXT)="iSP^Send Patient to Lab"
     91 I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect"
     92 S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK")
     93 I $L(Y) S LST($$NXT)="d"_Y
     94 Q
     95INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE
     96 N X,X1,X2,%H
     97 S X1=ADATE,X2=1 D C^%DTC S ADATE=X
     98 S ADATE("H")=ADATE("H")+1
     99 S ADATE("DOW")=ADATE("H")#7
     100 S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1)
     101 Q
     102DOWNAME(DOW) ; function
     103 ; Returns Day of Week name (DOW should be $H#7)
     104 I DOW=0 Q "Thursday"
     105 I DOW=1 Q "Friday"
     106 I DOW=2 Q "Saturday"
     107 I DOW=3 Q "Sunday"
     108 I DOW=4 Q "Monday"
     109 I DOW=5 Q "Tuesday"
     110 I DOW=6 Q "Wednesday"
     111 Q ""
     112URGENCY ; return default urgency for lab
     113 N URG
     114 S URG=$$DEFURG^LR7OR3
     115 S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1)
     116 S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1)
     117 Q
     118SCHED ; return list of schedules available for lab tests
     119 N X,X0,IEN
     120 S X="" F  S X=$O(^PS(51.1,"APLR",X)) Q:X=""  S IEN=$O(^(X,0)) I IEN D
     121 . S X0=$G(^PS(51.1,IEN,0)) Q:X0=""
     122 . I (($P(X0,U,5)="C")!($P(X0,U,5)="D")),(+$P(X0,U,3)=0) Q
     123 . S LST($$NXT)="i"_IEN_U_X_U_$P(X0,U,5)_U_$P(X0,U,3)
     124 . I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X
     125 Q
     126COMMON ; return list of commonly ordered lab tests
     127 N ORLST,IEN,I
     128 D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT")  ;DBIA 2263
     129 S I=0 F  S I=$O(ORLST(I)) Q:'I  D
     130 . S IEN=$P(ORLST(I),U,2)
     131 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
     132 Q
     133LOAD(LST,TESTID) ; procedure
     134 ; Return sample, specimen, & urgency info about a lab test
     135 N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM
     136 S ILST=0
     137 S LST($$NXT)="~Test Name"
     138 S LST($$NXT)="d"_$P(^ORD(101.43,TESTID,0),U,1),ORLABID=$P(^(0),U,2)
     139 S LST($$NXT)="~Item ID"
     140 S LST($$NXT)="d"_+ORLABID
     141 S X=$P(ORLABID,";",1),X1=$P(ORLABID,";",2)
     142 I $E(X1,1,4)="99VB" S X1=$O(^LAB(60,"B","VBECS "_$P(^ORD(101.43,TESTID,0),"^"),0)) Q:'X1  S X=X1
     143 S X4=$P($G(^LAB(60,X,0)),U,4)
     144 S LST(ILST)=LST(ILST)_U_X4
     145 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
     146 S I=0 F  S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I  S LST($$NXT)="t"_^(I,0)
     147 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
     148 D TEST^LR7OR3(TESTID,.ORY)
     149 S PARAM="" F  S PARAM=$O(ORY(PARAM)) Q:PARAM=""  D
     150 . S LST($$NXT)="~"_PARAM
     151 . I PARAM="ReqCom" D
     152 . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q
     153 . I PARAM="Default CollSamp" D
     154 . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q
     155 . I PARAM="Unique CollSamp" D
     156 . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q
     157 . I PARAM="Default Urgency" D
     158 . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q
     159 . I PARAM="Lab CollSamp" D
     160 . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q
     161 . I $D(ORY(PARAM))>1 S I=0 F  S I=$O(ORY(PARAM,I)) Q:'I  D
     162 . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q
     163 . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q
     164 . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q
     165 . . S LST($$NXT)="i"_I_U_ORY(PARAM,I)
     166 . . I PARAM="CollSamp" D
     167 . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1
     168 . . . S X=+$P(ORY(PARAM,I),U,3)
     169 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
     170 . . I $D(ORY(PARAM,I,"WP")) S J=0 F  S J=$O(ORY(PARAM,I,"WP",J)) Q:'J  D
     171 . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0)
     172 Q
     173ALLSAMP(LST) ; procedure
     174 ; returns all collection samples
     175 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
     176 N SMP,SPC,ILST,IEN,X,X0
     177 S ILST=0,LST($$NXT)="~CollSamp"
     178 S SMP="" F  S SMP=$O(^LAB(62,"B",SMP)) Q:SMP=""  D
     179 . S IEN=0 F  S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN  D
     180 . . S X0=^LAB(62,IEN,0)
     181 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
     182 . . I $P(X0,U,2) D
     183 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
     184 . . . S SPC($P(X,U,4))=$P(X,U,10)
     185 . . S LST($$NXT)=X
     186 S LST($$NXT)="~Specimens"
     187 S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
     188 Q
     189ONESAMP(LST,IEN) ;Return data for one colelction sample
     190 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
     191 N SPC,ILST,X,X0
     192 Q:+$G(IEN)=0
     193 S ILST=0,LST($$NXT)="~CollSamp"
     194 S X0=^LAB(62,IEN,0)
     195 S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
     196 I $P(X0,U,2) D
     197 . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
     198 . S SPC($P(X,U,4))=$P(X,U,10)
     199 S LST($$NXT)=X
     200 S LST($$NXT)="~Specimens"
     201 S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
     202 Q
     203ONESPEC(LST,IEN) ;return one specimen
     204 Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0)))
     205 S LST=IEN_U_$P(^LAB(61,IEN,0),U,1)
     206 Q
     207ABBSPEC(LST) ; procedure
     208 ; returns specimens with abbreviation (uses 'E' xref)
     209 N X,IEN,ILST S ILST=0
     210 S X="" F  S X=$O(^LAB(61,"E",X)) Q:X=""  S IEN=$O(^(X,0)) D
     211 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
     212 Q
     213NXT() ; called by TESTINFO, increments ILST
     214 S ILST=ILST+1
     215 Q ILST
     216 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR33.m

    r613 r623  
    1 ORWDLR33        ; SLC/KCM/REV/JDL - Lab Calls ; 7/1/2002 11AM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,243**;Dec 17, 1997;Build 242
    3         ;
    4 STOP(VAL,X2)          ; return a calculated stop date
    5         N X1,X
    6         S X1=DT D C^%DTC S VAL=X
    7         Q
    8 MAXDAYS(Y,LOC,SCHED)    ; Return max number of days for a continuing order
    9         N TMP1,TMP2
    10         K ^TMP($J,"ORWDLR33 MAXDAYS")
    11         S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q")
    12         I +TMP1=0 S Y="-1" Q
    13         I +$G(SCHED)>0 D ZERO^PSS51P1(SCHED,,,,"ORWDLR33 MAXDAYS") S TMP2=$G(^TMP($J,"ORWDLR33 MAXDAYS",SCHED,2.5)) K ^TMP($J,"ORWDLR33 MAXDAYS")
    14         E  S TMP2=0
    15         I +TMP1=0,+TMP2>0 S Y=TMP2 Q
    16         I +TMP2=0,+TMP1>0 S Y=TMP1 Q
    17         S Y=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0)
    18         K ^TMP($J,"ORWDLR33 MAXDAYS")
    19         Q
    20 ALLSPEC(Y,FROM,DIR)     ; Return a set of specimens from topography file
    21         N I,IEN,CNT S I=0,CNT=44
    22         F  Q:I'<CNT  S FROM=$O(^LAB(61,"B",FROM),DIR) Q:FROM=""  D
    23         . S IEN=0 F  S IEN=$O(^LAB(61,"B",FROM,IEN)) Q:'IEN  D
    24         . . S I=I+1,Y(I)=IEN_U_FROM_"  ("_$P($G(^LAB(61,IEN,0)),U,2)_")"
    25         Q
    26 LABCOLTM(ORYN,ORDATE,ORLOC)     ; Is this a routine lab collect time for this location?
    27         N ORDA,ORTI,ORDOW,ORCTM,I,X,Y
    28         S ORYN=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC))
    29         S ORDA=$P(ORDATE,".",1),ORTI=$P(ORDATE,".",2)
    30         S I=0 F  S I=$L(ORTI) Q:I>3  S ORTI=ORTI_"0"
    31         S X=ORDA D DW^%DTC S ORDOW=X
    32         D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
    33         S I=0 F  S I=$O(ORCTM(I)) Q:'I  D
    34         . S:$P(ORCTM(I),U,2)=ORTI ORYN=1
    35         Q:ORYN=0
    36         I $G(ORLOC),$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") S ORYN=1 Q
    37         I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORYN=0 Q
    38         I $$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORYN=1 Q
    39         S ORYN=0
    40         Q
    41 IMMCOLL(ORY)    ; Return help screen showing immediate collect times
    42         D SHOW^LR7OV4(DUZ(2),.ORY)
    43         Q
    44 ICDEFLT(ORY)    ;Return default immediate collect time
    45         S ORY=$$DEFTIME^LR7OV4(DUZ(2))
    46         Q
    47 ICVALID(ORY,ORTIME)     ;Is the time a valid immediate collect time?
    48         S ORTIME=$P(ORTIME,".",1)_"."_$E($P(ORTIME,".",2),1,4)
    49         S ORY=$$VALID^LR7OV4(DUZ(2),ORTIME)
    50         Q
    51 GETLABTM(ORY,ORDATE,ORLOC)      ;Return list of lab collect times for a date and location
    52         N ORDA,ORTI,ORNOW,ORDOW,ORCTM,ORTI,X,%,%H
    53         S ORY(0)=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC))
    54         S ORDA=$P(ORDATE,".",1)
    55         S ORNOW=$$NOW^XLFDT,ORTI=$P(ORNOW,".",2)
    56         I ORDA<$P(ORNOW,".",1) S ORY(0)="-1^Dates in the past are not allowed." Q
    57         I '+$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
    58         . S X=ORDA D DW^%DTC S ORDOW=X
    59         . I '+$$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORY(0)="-1^No collections on "_ORDOW Q
    60         . I '+$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORY(0)="-1^No holiday collections" Q
    61         I +ORY(0)>-1 D
    62         . D GETLST^XPAR(.ORY,"ALL","LR PHLEBOTOMY COLLECTION","Q")
    63         . I +$G(ORY)=0 S ORY(0)="-1^No lab collect times defined for this division" Q
    64         S I=0 F  S I=$O(ORY(I)) Q:'I  D
    65         . D NOW^%DTC S ORTI=%,%H=+%H_","_+ORY(I) D YMD^%DTC
    66         . I (ORDA=$P(ORTI,".",1)),(+(ORDA+%)<+ORTI) K ORY(I) S ORY=ORY-1 Q   ; cutoff time has passed for this collect time
    67         . S ORY(I)=$P(ORY(I),U,2)
    68         I +$G(ORY)=0,('$D(ORY(0))) S ORY(0)="-1^All of today's collection times have passed."
    69         Q
    70 LCFUTR(ORDY,ORLOC,ORDIV)         ;Get # of days for future Lab Collects
    71         ; For Event Delay Order
    72         ;  --ORLOC Event default location
    73         ;  --ORDIV Event default division
    74         S ORDY=0
    75         Q:'$D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE"))
    76         I $G(ORDIV) S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","LR LAB COLLECT FUTURE",1,"I")
    77         E  S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^DIV^SYS^PKG","LR LAB COLLECT FUTURE",1,"I")
    78         ;S DUZ(2)=TMPDIV
    79         Q
    80 LASTTIME(ORY)     ; Get last collection time used from ^TMP("ORECALL",$J) array
    81         N ORDIALOG,ORTYPE,ORTIME
    82         S ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0))
    83         S ORTYPE=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
    84         S ORTIME=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
    85         S ORY=$$RECALL^ORCD(ORTYPE,1)_U_$$RECALL^ORCD(ORTIME,1)
    86         Q
    87 LCTOWC(ORTXT,ORLOC)         ; return text instructing user when LC changed to WC on accept/release
    88         N ORDIV,ORSVC
    89         S ORDIV=DUZ(2)
    90         S ORSVC=+$G(^VA(200,DUZ,5))
    91         I ORSVC S ORTXT=$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORSVC)_";DIC(49,^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","ORWLR LC CHANGED TO WC",1,"I")
    92         E  S ORTXT=$$GET^XPAR(+$G(ORLOC)_";SC("_"^SVC^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","ORWLR LC CHANGED TO WC",1,"I")
    93         Q
     1ORWDLR33 ; SLC/KCM/REV/JDL - Lab Calls ; 7/1/2002 11AM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141**;Dec 17, 1997
     3 ;
     4STOP(VAL,X2)       ; return a calculated stop date
     5 N X1,X
     6 S X1=DT D C^%DTC S VAL=X
     7 Q
     8MAXDAYS(Y,LOC,SCHED) ; Return max number of days for a continuing order
     9 N TMP1,TMP2
     10 S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q")
     11 I +TMP1=0 S Y="-1" Q
     12 I +$G(SCHED)>0 S TMP2=$P($G(^PS(51.1,SCHED,0)),U,7)
     13 E  S TMP2=0
     14 I +TMP1=0,+TMP2>0 S Y=TMP2 Q
     15 I +TMP2=0,+TMP1>0 S Y=TMP1 Q
     16 S Y=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0)
     17 Q
     18ALLSPEC(Y,FROM,DIR) ; Return a set of specimens from topography file
     19 N I,IEN,CNT S I=0,CNT=44
     20 F  Q:I'<CNT  S FROM=$O(^LAB(61,"B",FROM),DIR) Q:FROM=""  D
     21 . S IEN=0 F  S IEN=$O(^LAB(61,"B",FROM,IEN)) Q:'IEN  D
     22 . . S I=I+1,Y(I)=IEN_U_FROM_"  ("_$P($G(^LAB(61,IEN,0)),U,2)_")"
     23 Q
     24LABCOLTM(ORYN,ORDATE,ORLOC) ; Is this a routine lab collect time for this location?
     25 N ORDA,ORTI,ORDOW,ORCTM,I,X,Y
     26 S ORYN=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC))
     27 S ORDA=$P(ORDATE,".",1),ORTI=$P(ORDATE,".",2)
     28 S I=0 F  S I=$L(ORTI) Q:I>3  S ORTI=ORTI_"0"
     29 S X=ORDA D DW^%DTC S ORDOW=X
     30 D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
     31 S I=0 F  S I=$O(ORCTM(I)) Q:'I  D
     32 . S:$P(ORCTM(I),U,2)=ORTI ORYN=1
     33 Q:ORYN=0
     34 I $G(ORLOC),$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") S ORYN=1 Q
     35 I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORYN=0 Q
     36 I $$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORYN=1 Q
     37 S ORYN=0
     38 Q
     39IMMCOLL(ORY) ; Return help screen showing immediate collect times
     40 D SHOW^LR7OV4(DUZ(2),.ORY)
     41 Q
     42ICDEFLT(ORY) ;Return default immediate collect time
     43 S ORY=$$DEFTIME^LR7OV4(DUZ(2))
     44 Q
     45ICVALID(ORY,ORTIME) ;Is the time a valid immediate collect time?
     46 S ORTIME=$P(ORTIME,".",1)_"."_$E($P(ORTIME,".",2),1,4)
     47 S ORY=$$VALID^LR7OV4(DUZ(2),ORTIME)
     48 Q
     49GETLABTM(ORY,ORDATE,ORLOC) ;Return list of lab collect times for a date and location
     50 N ORDA,ORTI,ORNOW,ORDOW,ORCTM,ORTI,X,%,%H
     51 S ORY(0)=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC))
     52 S ORDA=$P(ORDATE,".",1)
     53 S ORNOW=$$NOW^XLFDT,ORTI=$P(ORNOW,".",2)
     54 I ORDA<$P(ORNOW,".",1) S ORY(0)="-1^Dates in the past are not allowed." Q
     55 I '+$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
     56 . S X=ORDA D DW^%DTC S ORDOW=X
     57 . I '+$$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORY(0)="-1^No collections on "_ORDOW Q
     58 . I '+$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORY(0)="-1^No holiday collections" Q
     59 I +ORY(0)>-1 D
     60 . D GETLST^XPAR(.ORY,"ALL","LR PHLEBOTOMY COLLECTION","Q")
     61 . I +$G(ORY)=0 S ORY(0)="-1^No lab collect times defined for this division" Q
     62 S I=0 F  S I=$O(ORY(I)) Q:'I  D
     63 . D NOW^%DTC S ORTI=%,%H=+%H_","_+ORY(I) D YMD^%DTC
     64 . I (ORDA=$P(ORTI,".",1)),(+(ORDA+%)<+ORTI) K ORY(I) S ORY=ORY-1 Q   ; cutoff time has passed for this collect time
     65 . S ORY(I)=$P(ORY(I),U,2)
     66 I +$G(ORY)=0,('$D(ORY(0))) S ORY(0)="-1^All of today's collection times have passed."
     67 Q
     68LCFUTR(ORDY,ORLOC,ORDIV)  ;Get # of days for future Lab Collects
     69 ; For Event Delay Order
     70 ;  --ORLOC Event default location
     71 ;  --ORDIV Event default division
     72 S ORDY=0
     73 Q:'$D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE"))
     74 I $G(ORDIV) S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","LR LAB COLLECT FUTURE",1,"I")
     75 E  S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^DIV^SYS^PKG","LR LAB COLLECT FUTURE",1,"I")
     76 ;S DUZ(2)=TMPDIV
     77 Q
     78LASTTIME(ORY)   ; Get last collection time used from ^TMP("ORECALL",$J) array
     79 N ORDIALOG,ORTYPE,ORTIME
     80 S ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0))
     81 S ORTYPE=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
     82 S ORTIME=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
     83 S ORY=$$RECALL^ORCD(ORTYPE,1)_U_$$RECALL^ORCD(ORTIME,1)
     84 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDOR.m

    r613 r623  
    1 ORWDOR  ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96  8:21 AM ];03:50 PM  17 Jun 1998
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,164,253,243**;Dec 17, 1997;Build 242
    3 NXT()   ; -- returns next available index in return data array
    4         S ILST=ILST+1
    5         Q ILST
    6         ;
    7 VMSLCT(LST)     ; return default lists for vitals dialog
    8         N ILST S ILST=0
    9         S LST($$NXT)="~Measurements" D MEAS
    10         S LST($$NXT)="~Schedules"    D SCHED
    11         Q
    12 MEAS    ; called from VMSLCT
    13         N I,X
    14         S X="" F  S X=$O(^ORD(101.43,"S.V/M",X)) Q:X=""  D
    15         . S I=$O(^ORD(101.43,"S.V/M",X,0))
    16         . S LST($$NXT)="i"_I_U_$P(^ORD(101.43,"S.V/M",X,I),U,2)
    17         Q
    18 SCHED   ; called from VMSLCT
    19         N X,I
    20         K ^TMP($J,"ORWDGX APGMRV")
    21         D AP^PSS51P1("GMRV",,,,"ORWDGX APGMRV")
    22         S X="" F  S X=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X)) Q:X=""  D
    23         . S I=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X,0)),LST($$NXT)="i"_I_U_X
    24         K ^TMP($J,"ORWDGX APGMRV")
    25         Q
    26 VALNUM(ERR,X,DOM)       ; return error if invalid number
    27         N LOW,HIGH,DEC
    28         S LOW=$P(DOM,":"),HIGH=$P(DOM,":",2),DEC=$P(DOM,":",3),ERR=0
    29         I $L($P(X,"."))>24 S ERR="1^Exceeded maximum number of 24 characters" Q
    30         I X'?.1"-".N.1".".N S ERR="1^Entry must be numeric" Q
    31         I X>HIGH!(X<LOW) S ERR="1^Out of Range - value must be between "_LOW_" and "_HIGH_" inclusive" Q
    32         I $L($P(+X,".",2))>DEC D
    33         . I DEC=0 S ERR="1^No decimal places allowed"
    34         . E  I DEC=1 S ERR="1^Only one decimal place allowed"
    35         . E  S ERR="1^No more than "_DEC_" decimal places allowed"
    36         Q
    37 LKSCRN(ORLST,FROM,DIR,REF,GBL,SCR)      ; Return a set of entries from xref in REF
    38         ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
    39         ; REF=subscript indirection global ref including xref,
    40         ; GBL=standard FM global ref, SCR=reference to screen in 101.41
    41         N I,IEN,CNT,X,Y,D,ORTYPE
    42         S I=0,CNT=44,SCR=$G(SCR)
    43         I $L(SCR) S SCR=$G(^ORD(101.41,+SCR,10,+$P(SCR,":",2),4))
    44         S D=$P(REF,"""",2),ORTYPE="D" ;for OI screen
    45         F  Q:I'<CNT  S FROM=$O(@REF@(FROM),DIR) Q:FROM=""  D
    46         . S IEN=0 F  S IEN=$O(@REF@(FROM,IEN)) Q:'IEN  D
    47         . . ; if screen, set naked ref & Y, then execute screen
    48         . . I $L(SCR) S Y=IEN,X=$P($G(@(GBL_"Y,0)")),U) X SCR Q:'$T
    49         . . S I=I+1,ORLST(I)=IEN_"^"_FROM
    50         Q
    51 MNUTREE(LST,ROOT)       ; return menu tree for a menu type dialog
    52         N ILST S ILST=0
    53         S ILST=ILST+1,LST(ILST)=ROOT_U_$P(^ORD(101.41,ROOT,0),U,2)_"^0^+"
    54         D LSTCHLD(ROOT)
    55         Q
    56 LSTCHLD(PARENT) ; list descendends of this node (recursive)
    57         N CHILD,I,J
    58         S I=0 F  S I=$O(^ORD(101.41,PARENT,10,"B",I)) Q:'I  D
    59         . S J=0 F  S J=$O(^ORD(101.41,PARENT,10,"B",I,J)) Q:'J  D
    60         . . S CHILD=+$P(^ORD(101.41,PARENT,10,J,0),U,2) Q:'CHILD
    61         . . ; also quit if child is not a generic order
    62         . . S ILST=ILST+1,LST(ILST)=CHILD_U_$P(^ORD(101.41,CHILD,0),U,2)_U_PARENT
    63         . . I $P(^ORD(101.41,CHILD,0),U,4)="M",$D(^ORD(101.41,CHILD,10))>1 D
    64         . . . S LST(ILST)=LST(ILST)_"^+"
    65         . . . D LSTCHLD(CHILD)
    66         Q
     1ORWDOR ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96  8:21 AM ];03:50 PM  17 Jun 1998
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,164,253**;Dec 17, 1997
     3NXT() ; -- returns next available index in return data array
     4 S ILST=ILST+1
     5 Q ILST
     6 ;
     7VMSLCT(LST) ; return default lists for vitals dialog
     8 N ILST S ILST=0
     9 S LST($$NXT)="~Measurements" D MEAS
     10 S LST($$NXT)="~Schedules"    D SCHED
     11 Q
     12MEAS ; called from VMSLCT
     13 N I,X
     14 S X="" F  S X=$O(^ORD(101.43,"S.V/M",X)) Q:X=""  D
     15 . S I=$O(^ORD(101.43,"S.V/M",X,0))
     16 . S LST($$NXT)="i"_I_U_$P(^ORD(101.43,"S.V/M",X,I),U,2)
     17 Q
     18SCHED ; called from VMSLCT
     19 N I,X
     20 S X="" F  S X=$O(^PS(51.1,"APGMRV",X)) Q:X=""  D
     21 . S I=$O(^PS(51.1,"APGMRV",X,0)),LST($$NXT)="i"_I_U_X
     22 Q
     23VALNUM(ERR,X,DOM)       ; return error if invalid number
     24 N LOW,HIGH,DEC
     25 S LOW=$P(DOM,":"),HIGH=$P(DOM,":",2),DEC=$P(DOM,":",3),ERR=0
     26 I $L($P(X,"."))>24 S ERR="1^Exceeded maximum number of 24 characters" Q
     27 I X'?.1"-".N.1".".N S ERR="1^Entry must be numeric" Q
     28 I X>HIGH!(X<LOW) S ERR="1^Out of Range - value must be between "_LOW_" and "_HIGH_" inclusive" Q
     29 I $L($P(+X,".",2))>DEC D
     30 . I DEC=0 S ERR="1^No decimal places allowed"
     31 . E  I DEC=1 S ERR="1^Only one decimal place allowed"
     32 . E  S ERR="1^No more than "_DEC_" decimal places allowed"
     33 Q
     34LKSCRN(ORLST,FROM,DIR,REF,GBL,SCR) ; Return a set of entries from xref in REF
     35 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
     36 ; REF=subscript indirection global ref including xref,
     37 ; GBL=standard FM global ref, SCR=reference to screen in 101.41
     38 N I,IEN,CNT,X,Y,D,ORTYPE
     39 S I=0,CNT=44,SCR=$G(SCR)
     40 I $L(SCR) S SCR=$G(^ORD(101.41,+SCR,10,+$P(SCR,":",2),4))
     41 S D=$P(REF,"""",2),ORTYPE="D" ;for OI screen
     42 F  Q:I'<CNT  S FROM=$O(@REF@(FROM),DIR) Q:FROM=""  D
     43 . S IEN=0 F  S IEN=$O(@REF@(FROM,IEN)) Q:'IEN  D
     44 . . ; if screen, set naked ref & Y, then execute screen
     45 . . I $L(SCR) S Y=IEN,X=$P($G(@(GBL_"Y,0)")),U) X SCR Q:'$T
     46 . . S I=I+1,ORLST(I)=IEN_"^"_FROM
     47 Q
     48MNUTREE(LST,ROOT)        ; return menu tree for a menu type dialog
     49 N ILST S ILST=0
     50 S ILST=ILST+1,LST(ILST)=ROOT_U_$P(^ORD(101.41,ROOT,0),U,2)_"^0^+"
     51 D LSTCHLD(ROOT)
     52 Q
     53LSTCHLD(PARENT) ; list descendends of this node (recursive)
     54 N CHILD,I,J
     55 S I=0 F  S I=$O(^ORD(101.41,PARENT,10,"B",I)) Q:'I  D
     56 . S J=0 F  S J=$O(^ORD(101.41,PARENT,10,"B",I,J)) Q:'J  D
     57 . . S CHILD=+$P(^ORD(101.41,PARENT,10,J,0),U,2) Q:'CHILD
     58 . . ; also quit if child is not a generic order
     59 . . S ILST=ILST+1,LST(ILST)=CHILD_U_$P(^ORD(101.41,CHILD,0),U,2)_U_PARENT
     60 . . I $P(^ORD(101.41,CHILD,0),U,4)="M",$D(^ORD(101.41,CHILD,10))>1 D
     61 . . . S LST(ILST)=LST(ILST)_"^+"
     62 . . . D LSTCHLD(CHILD)
     63 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS1.m

    r613 r623  
    1 ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog; 03/10/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243**;Dec 17, 1997;Build 242
    3         ;
    4 ODSLCT(LST,PSTYPE,DFN,LOC)      ; return default lists for dialog
    5         ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
    6         N ILST S ILST=0
    7         S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR
    8         S ILST=ILST+1,LST(ILST)="~DispMsg"
    9         S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG
    10         ;
    11         ; I PSTYPE="F" D  Q                           ; IV Fluids
    12         ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT
    13         ;
    14         I PSTYPE="O" D                                ; Outpatient
    15         . S ILST=ILST+1,LST(ILST)="~Refills"
    16         . S ILST=ILST+1,LST(ILST)="d0^0"
    17         . S ILST=ILST+1,LST(ILST)="~Pickup"
    18         . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC))
    19         . ; S ILST=ILST+1,LST(ILST)="~Supply"
    20         . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN)
    21         Q
    22 PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV)        ; return DEA Schedule for drug
    23         N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X
    24         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
    25         S ILST=0
    26         S ORWPSOI=0
    27         S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
    28         D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc.
    29         I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses
    30         I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses NEW PKI CODE from pharmacy
    31         D EN^PSSDIN(ORWPSOI)                               ; nfi text
    32         S ORY="" ;PKI
    33         I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D
    34         . I '$L(X2) Q
    35         . I $G(PKIACTIV) S X=X2
    36         S ORY=X
    37         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
    38         Q
    39 PRIOR   ; from DLGSLCT, get list of allowed priorities
    40         N X,XREF
    41         S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")
    42         S X="" F  S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X)  D
    43         . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q
    44         . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
    45         S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
    46         Q
    47 DEFPICK(LOC)          ; return default routing
    48         N X,DLG,PRMT
    49         S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
    50         S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
    51         I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
    52         I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action
    53         ;
    54         ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")
    55         S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
    56         I X="C" S X="C^in Clinic" G XPICK
    57         I X="M" S X="M^by Mail"   G XPICK
    58         I X="W" S X="W^at Window" G XPICK
    59         I X="N" S X=""            G XPICK
    60         I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
    61 XPICK   Q X
    62         ;
    63 DEFSPLY(DFN)       ; return default days supply for this patient
    64         N ORWX
    65         S ORWX("PATIENT")=DFN
    66         D DSUP^PSOSIGDS(.ORWX)
    67         Q $G(ORWX("DAYS SUPPLY"))
    68         ;
    69 DFLTSPLY(VAL,UPD,SCH,PAT,DRG)          ; return days supply given quantity
    70         ; VAL: default days supply
    71         N ORWX,I
    72         S ORWX("PATIENT")=PAT
    73         I DRG S ORWX("DRUG")=DRG
    74         F I=1:1:$L(UPD,U)-1 D
    75         . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
    76         . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
    77         D DSUP^PSOSIGDS(.ORWX)
    78         S VAL=$G(ORWX("DAYS SUPPLY"))
    79         Q
    80 DISPMSG()             ; return 1 to suppress dispense message
    81         Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I")
    82         ;
    83 DOWSCH(LST,DFN,LOCIEN)      ; return all schedules
    84         N CNT,FREQ,ILST,ORARRAY,WIEN
    85         S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN))
    86         D SCHED^PSS51P1(WIEN,.ORARRAY)
    87         S ILST=0
    88         S CNT=0 F  S CNT=$O(ORARRAY(CNT)) Q:CNT'>0  D
    89         .S NODE=$G(ORARRAY(CNT))
    90         .I $P(NODE,U,4)="C" D
    91         ..K ^TMP($J,"ORWDPS1 DOWSCH")
    92         ..D ZERO^PSS51P1($P(NODE,U),,,,"ORWDPS1 DOWSCH")
    93         ..S FREQ=$G(^TMP($J,"ORWDPS1 DOWSCH",$P(NODE,U),2))
    94         ..K ^TMP($J,"ORWDPS1 DOWSCH")
    95         ..I +FREQ=0 Q
    96         ..I +FREQ>1440 Q
    97         ..S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5)
    98         Q
    99         ;
    100 SCHALL(LST,DFN,LOCIEN)      ; return all schedules
    101         N CNT,ILST,ORARRAY,WIEN
    102         S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN))
    103         D SCHED^PSS51P1(WIEN,.ORARRAY)
    104         S ILST=0
    105         S CNT=0 F  S CNT=$O(ORARRAY(CNT)) Q:CNT'>0  D
    106         .S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5)
    107         Q
    108         ;
    109 FORMALT(ORLST,ORIEN,PSTYPE)     ; return a list of formulary alternatives
    110         N PSID,I
    111         S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2)
    112         D EN1^PSSUTIL1(.ORIEN,PSTYPE)
    113         S PSID=0,I=0
    114         F  S PSID=$O(ORIEN(PSID)) Q:'PSID  D
    115         . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0))
    116         . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U)
    117         Q
    118 DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose
    119         N I,OI,ORWLST,ILST S ILST=0
    120         D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST)
    121         S I=0 F  S I=$O(ORWLST(I)) Q:'I  D
    122         . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0))
    123         . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U)
    124         Q
    125 QOMEDALT(ORY,ODIEN)     ;
    126         N ARRAY,IDIEN,ORDERID,PKG,PSTYPE,VALUE
    127         S ORY=0,PKG=+$P(^ORD(101.41,ODIEN,0),U,7)
    128         S PSTYPE=$S($$GET1^DIQ(9.4,PKG_",",1)="PSO":"O",1:"I")
    129         S ORDERID=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM","")) Q:ORDERID'>0
    130         S IDIEN=$O(^ORD(101.41,ODIEN,6,"D",ORDERID,"")) Q:IDIEN'>0
    131         S VALUE=$G(^ORD(101.41,ODIEN,6,IDIEN,1)) Q:VALUE'>0
    132         I $P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE
    133         ;D FORMALT(.ARRAY,VALUE,PSTYPE) I $D(ARRAY)>0 S ORY=VALUE
    134         ;I ORY=0,$P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE
    135         Q
    136 FAILDEA(FAIL,OI,ORNP,PSTYPE)       ; return 1 if DEA check fails for this provider
    137         N DEAFLG,PSOI,TPKG
    138         S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
    139         Q:TPKG'["PS"
    140         S PSOI=+TPKG Q:PSOI'>0
    141         I '$L($T(OIDEA^PSSUTLA1)) Q
    142         S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0
    143         I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1
    144         Q
    145 FDEA1(FAIL,OI,OITYPE,ORNP)      ; only be called for an outpaitent and IV dialog
    146         ;OI: IV Orderable Item
    147         ;OITYPE: A:ADDITIVE  S:SOLUTION
    148         N DEAFLG,PSOI,TKPG
    149         S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
    150         Q:TPKG'["PS"
    151         S PSOI=+TPKG Q:PSOI'>0
    152         I '$L($T(IVDEA^PSSUTIL1)) Q
    153         S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0
    154         I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1
    155         Q
    156         ;
    157 CHK94(VAL)           ; return 1 if patch 94 has been installed
    158         S VAL=0
    159         I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1
    160         Q
    161 LOCPICK(Y,LOC)  ; return default Location level routing
    162         S Y=""
    163         S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
    164         I Y="C" S Y="C^in Clinic"
    165         I Y="M" S Y="M^by Mail"
    166         I Y="W" S Y="W^at Window"
    167         I Y="N" S Y=""
    168         Q
    169 HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig
    170         N PIIEN,OIX
    171         S Y=0
    172         Q:'$D(^ORD(101.41,QOID,0))
    173         S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0))
    174         Q:'PIIEN
    175         S OIX=0
    176         Q:'$D(^ORD(101.41,QOID,6,"D"))
    177         F  S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX  D
    178         . I OIX=PIIEN S Y=1 Q
    179         Q
    180 HASROUTE(Y,QOID)        ;Check if QO has a ROUTE defined
    181         N ROUTID
    182         S Y=0,ROUTID=0
    183         S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0))
    184         Q:'ROUTID
    185         Q:'$D(^ORD(101.41,+QOID))
    186         I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1
    187         Q
    188 QOCHECK(ORY,DIEN)       ;
    189         N ARY,DG,FORMIEN,NAME,OI,OIIEN,ORDIALOG,ORPKG,TYPE
    190         S ORPKG=$$NMSP^ORCD($P($G(^ORD(101.41,DIEN,0)),U,7)) Q:ORPKG'["PS"
    191         S DG=$P(^ORD(101.41,DIEN,0),U,5)
    192         S NAME=$P(^ORD(100.98,DIEN,0),U)
    193         S TYPE=$S(NAME="INPATIENT MEDICATIONS":"I",NAME="OUTPATIENT MEDICATIONS":"O",1:"")
    194         I TYPE="" Q
    195         S ORDIALOG=$$DEFDLG^ORCD(DIEN) Q:ORDIALOG
    196         D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD("^ORD(101.41,"_DIEN_",6)")
    197         I $D(ORDIALOG)'>0 Q
    198         S OI=$P($G(ORDIALOG("B","ORDERABLE")),U,2) Q:OI'>0
    199         S OIIEN=$G(ORDIALOG(OI,1)) Q:OIIEN'>0
    200         D FORMALT(.ARY,OIIEN,TYPE) I $D(ARY)'>0 Q
    201         S ORY=OIIEN
    202         Q
     1ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog ; 10/04/2005
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255**;Dec 17, 1997
     3 ;
     4ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog
     5 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
     6 N ILST S ILST=0
     7 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR
     8 S ILST=ILST+1,LST(ILST)="~DispMsg"
     9 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG
     10 ;
     11 ; I PSTYPE="F" D  Q                           ; IV Fluids
     12 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT
     13 ;
     14 I PSTYPE="O" D                                ; Outpatient
     15 . S ILST=ILST+1,LST(ILST)="~Refills"
     16 . S ILST=ILST+1,LST(ILST)="d0^0"
     17 . S ILST=ILST+1,LST(ILST)="~Pickup"
     18 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC))
     19 . ; S ILST=ILST+1,LST(ILST)="~Supply"
     20 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN)
     21 Q
     22PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug
     23 N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X
     24 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
     25 S ILST=0
     26 S ORWPSOI=0
     27 S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
     28 D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc.
     29 I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses
     30 I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses NEW PKI CODE from pharmacy
     31 D EN^PSSDIN(ORWPSOI)                               ; nfi text
     32 S ORY="" ;PKI
     33 I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D
     34 . I '$L(X2) Q
     35 . I $G(PKIACTIV) S X=X2
     36 S ORY=X
     37 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
     38 Q
     39PRIOR ; from DLGSLCT, get list of allowed priorities
     40 N X,XREF
     41 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")
     42 S X="" F  S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X)  D
     43 . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q
     44 . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
     45 S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
     46 Q
     47DEFPICK(LOC)       ; return default routing
     48 N X,DLG,PRMT
     49 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
     50 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
     51 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
     52 I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action
     53 ;
     54 ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")
     55 S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
     56 I X="C" S X="C^in Clinic" G XPICK
     57 I X="M" S X="M^by Mail"   G XPICK
     58 I X="W" S X="W^at Window" G XPICK
     59 I X="N" S X=""            G XPICK
     60 I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
     61XPICK Q X
     62 ;
     63DEFSPLY(DFN)    ; return default days supply for this patient
     64 N ORWX
     65 S ORWX("PATIENT")=DFN
     66 D DSUP^PSOSIGDS(.ORWX)
     67 Q $G(ORWX("DAYS SUPPLY"))
     68 ;
     69DFLTSPLY(VAL,UPD,SCH,PAT,DRG)        ; return days supply given quantity
     70 ; VAL: default days supply
     71 N ORWX,I
     72 S ORWX("PATIENT")=PAT
     73 I DRG S ORWX("DRUG")=DRG
     74 F I=1:1:$L(UPD,U)-1 D
     75 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
     76 . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
     77 D DSUP^PSOSIGDS(.ORWX)
     78 S VAL=$G(ORWX("DAYS SUPPLY"))
     79 Q
     80DISPMSG()       ; return 1 to suppress dispense message
     81 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I")
     82 ;
     83SCHALL(LST)     ; return all schedules
     84 N ILST,SCH,IEN,EXP,TYP,X0
     85 S ILST=0,SCH=""
     86 F  S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH=""  D
     87 . S IEN=0,EXP=""
     88 . F  S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:'IEN  D  Q:$L(EXP)
     89 . . S X0=$G(^PS(51.1,IEN,0)),EXP=$P(X0,U,8),TYP=$P(X0,U,5)
     90 . S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP
     91 Q
     92FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives
     93 N PSID,I
     94 S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2)
     95 D EN1^PSSUTIL1(.ORIEN,PSTYPE)
     96 S PSID=0,I=0
     97 F  S PSID=$O(ORIEN(PSID)) Q:'PSID  D
     98 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0))
     99 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U)
     100 Q
     101DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose
     102 N I,OI,ORWLST,ILST S ILST=0
     103 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST)
     104 S I=0 F  S I=$O(ORWLST(I)) Q:'I  D
     105 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0))
     106 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U)
     107 Q
     108FAILDEA(FAIL,OI,ORNP,PSTYPE)    ; return 1 if DEA check fails for this provider
     109 N DEAFLG,PSOI,TPKG
     110 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
     111 Q:TPKG'["PS"
     112 S PSOI=+TPKG Q:PSOI'>0
     113 I '$L($T(OIDEA^PSSUTLA1)) Q
     114 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0
     115 I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1
     116 Q
     117FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog
     118 ;OI: IV Orderable Item
     119 ;OITYPE: A:ADDITIVE  S:SOLUTION
     120 N DEAFLG,PSOI,TKPG
     121 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
     122 Q:TPKG'["PS"
     123 S PSOI=+TPKG Q:PSOI'>0
     124 I '$L($T(IVDEA^PSSUTIL1)) Q
     125 S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0
     126 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1
     127 Q
     128 ;
     129CHK94(VAL)      ; return 1 if patch 94 has been installed
     130 S VAL=0
     131 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1
     132 Q
     133LOCPICK(Y,LOC) ; return default Location level routing
     134 S Y=""
     135 S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
     136 I Y="C" S Y="C^in Clinic"
     137 I Y="M" S Y="M^by Mail"
     138 I Y="W" S Y="W^at Window"
     139 I Y="N" S Y=""
     140 Q
     141HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig
     142 N PIIEN,OIX
     143 S Y=0
     144 Q:'$D(^ORD(101.41,QOID,0))
     145 S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0))
     146 Q:'PIIEN
     147 S OIX=0
     148 Q:'$D(^ORD(101.41,QOID,6,"D"))
     149 F  S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX  D
     150 . I OIX=PIIEN S Y=1 Q
     151 Q
     152HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined
     153 N ROUTID
     154 S Y=0,ROUTID=0
     155 S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0))
     156 Q:'ROUTID
     157 Q:'$D(^ORD(101.41,+QOID))
     158 I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1
     159 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m

    r613 r623  
    1 ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog;05/09/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243**;Dec 17, 1997;Build 242
    3         ;
    4 OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV)      ; return for defaults for pharmacy orderable item
    5         N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2
    6         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
    7         S ILST=0
    8         S ORWPSOI=0
    9         S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
    10         D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc.
    11         I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses
    12         I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses NEW PKI CODE from pharmacy
    13         D EN^PSSDIN(ORWPSOI)                               ; nfi text
    14         S ILST=ILST+1,LST(ILST)="~Medication"
    15         S ILST=ILST+1,LST(ILST)="d"_OI_U_$S(+OI:$P(^ORD(101.43,OI,0),U),1:"")
    16         S ILST=ILST+1,LST(ILST)="~Verb"
    17         S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U)
    18         S ILST=ILST+1,LST(ILST)="~Preposition"
    19         S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U,2)
    20         I $D(NEEDPI),(NEEDPI="Y") S ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR
    21         ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr"   D PTINSTR
    22         S ILST=ILST+1,LST(ILST)="~AllDoses"  D ALLDOSE ; must do before DOSAGE
    23         S ILST=ILST+1,LST(ILST)="~Dosage"    D DOSAGE
    24         S ILST=ILST+1,LST(ILST)="~Dispense"  D DISPLST
    25         S ILST=ILST+1,LST(ILST)="~Route"     D ROUTE
    26         S ILST=ILST+1,LST(ILST)="~Schedule"  D SCHED
    27         S ILST=ILST+1,LST(ILST)="~Guideline" D GUIDE
    28         S ILST=ILST+1,LST(ILST)="~Message"   D OIMSG
    29         S ILST=ILST+1,LST(ILST)="~DEASchedule" ;PKI
    30         ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI
    31         S ILST=ILST+1,LST(ILST)="d" ;PKI
    32         I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D
    33         . I '$L(X2) Q
    34         . I $G(PKIACTIV)="Y" S X=X2
    35         S LST(ILST)=LST(ILST)_X
    36         I PSTYPE="U" D
    37         . ; start, expires, next admin
    38         I PSTYPE="O" D
    39         . ; days supply, quantity, refills
    40         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
    41         Q
    42         ;
    43 PTINSTR ; from OISLCT, set up patient instructions
    44         N I
    45         S I=0 F  S I=$O(ORDOSE("PI",I)) Q:I'>0  S ILST=ILST+1,LST(ILST)="t"_ORDOSE("PI",I)
    46         Q
    47 DOSAGE  ; from OISLCT, set up the list of dosages
    48         ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
    49         ; must be called after ALLDOSE so ORWDOSES is set up
    50         N I
    51         S I=0 F  S I=$O(ORWDOSES(I)) Q:I'>0  S ILST=ILST+1,LST(ILST)=ORWDOSES(I)
    52         Q
    53 DISPLST ; from OISLCT, set up list of dispense drugs
    54         ; DrugIEN^Strength^Units^Name^Split
    55         N DD
    56         S DD=0 F  S DD=$O(ORDOSE("DD",DD)) Q:'DD  D
    57         . S ILST=ILST+1
    58         . S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11)
    59         Q
    60 ALLDOSE ; from OISLCT, set up a list of all possible doses
    61         ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
    62         N I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X
    63         S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0
    64         S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" "
    65         S I=0 F  S I=$O(ORDOSE(I)) Q:I'>0  D
    66         . S X=$$BLDDOSE(ORDOSE(I))
    67         . S ORWDOSES=ORWDOSES+1,ORWDOSES(ORWDOSES)=X
    68         . S ILST=ILST+1
    69         . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
    70         . S J=0 F  S J=$O(ORDOSE(I,J)) Q:J'>0  D
    71         . . S X=$$BLDDOSE(ORDOSE(I,J))
    72         . . S ILST=ILST+1
    73         . . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
    74         Q
    75 BLDDOSE(X)      ; build dose info where X is ORDOSE node
    76         ; from ALLDOSE
    77         ;    X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN
    78         ;    Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^
    79         ;      DoseText^CostText^MaxRefills^DispUnits^CanSplit
    80         ; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^
    81         ; No TotalDose,           use LocalDose
    82         ; TotalDose & Strength,   use LocalDose+Conjunction+Strength+Units
    83         ; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName
    84         S DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD),DDNM=$P(DRUG,U),ID=$P(X,U,1,6)
    85         S LDOSE=$P(X,U,5),TEXT=LDOSE,STREN=$P(DRUG,U,5)_$P(DRUG,U,6)
    86         S $P(ID,U,7)=$P(DRUG,U,5) S $P(ID,U,8)=$P(DRUG,U,6) ; add strength
    87         I '$L($P(X,U)),$L($P(DRUG,U,5))  S TEXT=TEXT_CONJ_STREN
    88         I '$L($P(X,U)),'$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_$P(DRUG,U)
    89         S UD=$P(X,U,3),COST=$P(X,U,7),NF=$S($P(DRUG,U,3):"NF",1:"")
    90         ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4)
    91         S Y="i"_DDNM_U_STREN_U_NF_U_$TR(ID,U,"&")_U_TEXT_U_COST_U_$P(DRUG,U,8)_U_$P(DRUG,U,4)
    92         Q Y
    93 ROUTE   ; from OISLCT, get list of routes for the drug form
    94         ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
    95         N I,CNT,ABBR,IEN,ROUT,EXP,X
    96         S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
    97         . S X=^TMP("PSJMR",$J,I)
    98         . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
    99         . S ILST=ILST+1,LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$P(X,U,5)
    100         . I $P(X,U,6)="D",IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
    101         ; add abbreviations to list of routes, commented out for 15.5 on
    102         ; S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
    103         ; . S X=^TMP("PSJMR",$J,I)
    104         ; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
    105         ; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP
    106         Q
    107 SCHED   ; from OISLCT, get default schedule for this medication
    108         I $L($G(^TMP("PSJSCH",$J))) S ILST=ILST+1,LST(ILST)="d"_^($J)
    109         Q
    110 GUIDE   ; from OISLCT, get guidelines associated with this medication
    111         N IEN,I
    112         S IEN=0 F  S IEN=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN)) Q:'IEN  D
    113         . S I=0 F  S I=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)) Q:'I  D
    114         . . S ILST=ILST+1,LST(ILST)="t"_^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)
    115         Q
    116 OIMSG   ; from OISLCT, get the orderable item message for this medication
    117         S I=0 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  S ILST=ILST+1,LST(ILST)="t"_^(I,0)
    118         Q
    119 ADMIN(REC,DFN,SCH,OI,LOC,ADMIN) ; return administration time info
    120         ; REC: StartText^StartTime^Duration^FirstAdmin
    121         S OI=+$P($G(^ORD(101.43,+OI,0)),U,2)
    122         S LOC=+$G(^SC(LOC,42)),REC=""
    123         I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH,"",$G(ADMIN))
    124         Q
    125 REQST(VAL,DFN,SCH,OI,LOC,TXT)   ; return requested start time
    126         ; VAL: FirstAdmin time
    127         S VAL=""
    128         Q:'$L($G(SCH))  Q:'$G(OI)
    129         S OI=+$P($G(^ORD(101.43,+OI,0)),U,2)
    130         S LOC=+$G(^SC(LOC,42))
    131         S VAL=$P($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2)
    132         Q
    133 DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG)    ; return qty for days supply
    134         ; VAL: quantity
    135         N ORWX,I,X,ADUR,ADURNM
    136         S ORWX("DAYS SUPPLY")=DAY
    137         S ORWX("PATIENT")=PAT
    138         I DRG S ORWX("DRUG")=DRG
    139         F I=1:1:$L(UPD,U)-1 D
    140         . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
    141         . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
    142         . S ADUR=$P(DUR,U,I),ADURNM=$P($P(ADUR," ",2),"~")
    143         . S:ADURNM="MONTHS" X=+ADUR_"L"
    144         . S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2))
    145         . I $L(X) S ORWX("DURATION",I)=X
    146         . S X=$E($P(ADUR,"~",2))
    147         . I $L(X) S ORWX("CONJUNCTION",I)=X
    148         D QTYX^PSOSIG(.ORWX)
    149         S VAL=$G(ORWX("QTY"))
    150         Q
    151 QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG)    ; return days supply given quantity
    152         ; VAL: days supply
    153         N ORWX,I,X,ADUR
    154         S ORWX("QTY")=QTY
    155         S ORWX("PATIENT")=PAT
    156         I DRG S ORWX("DRUG")=DRG
    157         F I=1:1:$L(UPD,U)-1 D
    158         . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
    159         . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
    160         . S ADUR=$P(DUR,U,I),X=+ADUR_$E($P(ADUR," ",2))
    161         . I $L(X) S ORWX("DURATION",I)=X
    162         . S X=$E($P(ADUR,"~",2))
    163         . I $L(X) S ORWX("CONJUNCTION",I)=X
    164         D QTYX^PSOSIG(.ORWX)
    165         S VAL=$G(ORWX("DAYS SUPPLY"))
    166         Q
    167 MAXREF(VAL,PAT,DRG,SUP,OI,OUT)  ; return the maximum number of refills
    168         ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item
    169         ; VAL: maximum refills allowed
    170         N ORWX
    171         S ORWX("PATIENT")=PAT
    172         I $G(DRG) S ORWX("DRUG")=+DRG
    173         I $G(SUP) S ORWX("DAYS SUPPLY")=SUP
    174         I $G(OI)  S ORWX("ITEM")=+$P(^ORD(101.43,+OI,0),U,2)
    175         I $G(OUT) S ORWX("DISCHARGE")=1
    176         D MAX^PSOSIGDS(.ORWX)
    177         S VAL=$G(ORWX("MAX"))
    178         Q
    179 SCHREQ(VAL,OI,RTE,DRG)  ; return 1 if schedule is required
    180         ; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug
    181         S VAL=1
    182         Q:'$G(OI)  Q:'$G(RTE)
    183         S VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$G(DRG))
    184         Q
    185 CHKPI(VAL,ODIFN)        ; return pre-existing patient instruct
    186         N IDNUM,IDPI
    187         S (IDNUM,IDPI)=0,VAL=""
    188         I '$D(^OR(100,ODIFN,4.5,"ID","PI")) S VAL="" Q
    189         F  S IDNUM=$O(^OR(100,ODIFN,4.5,"ID","PI",IDNUM)) Q:'IDNUM  D
    190         . F  S IDPI=$O(^OR(100,ODIFN,4.5,IDNUM,2,IDPI)) Q:'IDPI  D
    191         .. S VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0)
    192         K IDNUM,IDPI
    193         Q
    194 CHKGRP(VAL,ORIFN)       ;
    195         ;Inpatient Med Order Group or Clin Meds Group: return 1
    196         ;If order belong to Outpatient Med Order Grpoup: return 2
    197         ;Otherwise, return 0
    198         S VAL=0
    199         I '$L(ORIFN) Q
    200         N UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED
    201         S ODID=+ORIFN
    202         Q:ODID<1
    203         S (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0
    204         S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP))
    205         S OPGRP=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP))
    206         S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
    207         S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
    208         S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP))
    209         I $L($G(^OR(100,ODID,0)))<1 Q
    210         S ODGRP=$P(^OR(100,ODID,0),U,11)
    211         I (UDGRP=ODGRP)!(CLMED=ODGRP) S VAL=1
    212         I IPGRP=ODGRP S VAL=1
    213         I OPGRP=ODGRP S VAL=2
    214         K UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED
    215         Q
    216 QOGRP(VAL,QOIFN)        ;
    217         ;If quick order belong to Inpatient Med Order Group: return 1
    218         ;Otherwise, return 0
    219         S VAL=0
    220         I '$L(QOIFN) Q
    221         N UDGRP,IPGRP,QOGRP,QOID,CLMED
    222         S QOID=+QOIFN
    223         Q:QOID<1
    224         S (UDGRP,IPGRP,QOGRP,CLMED)=0
    225         S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP))
    226         S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
    227         S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
    228         S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP))
    229         I $L($G(^ORD(101.41,QOID,0)))<1 Q
    230         S QOGRP=$P(^ORD(101.41,QOID,0),U,5)
    231         I UDGRP=QOGRP S VAL=1
    232         I (IPGRP=QOGRP)!(CLMED=QOGRP) S VAL=1
    233         K UDGRP,QOGRP,QOID,IPGRP,CLMED
    234         Q
     1ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258**;Dec 17, 1997;Build 7
     3 ;
     4OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item
     5 N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2
     6 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
     7 S ILST=0
     8 S ORWPSOI=0
     9 S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
     10 D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc.
     11 I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses
     12 I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses NEW PKI CODE from pharmacy
     13 D EN^PSSDIN(ORWPSOI)                               ; nfi text
     14 S ILST=ILST+1,LST(ILST)="~Medication"
     15 S ILST=ILST+1,LST(ILST)="d"_OI_U_$S(+OI:$P(^ORD(101.43,OI,0),U),1:"")
     16 S ILST=ILST+1,LST(ILST)="~Verb"
     17 S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U)
     18 S ILST=ILST+1,LST(ILST)="~Preposition"
     19 S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U,2)
     20 I $D(NEEDPI),(NEEDPI="Y") S ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR
     21 ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr"   D PTINSTR
     22 S ILST=ILST+1,LST(ILST)="~AllDoses"  D ALLDOSE ; must do before DOSAGE
     23 S ILST=ILST+1,LST(ILST)="~Dosage"    D DOSAGE
     24 S ILST=ILST+1,LST(ILST)="~Dispense"  D DISPLST
     25 S ILST=ILST+1,LST(ILST)="~Route"     D ROUTE
     26 S ILST=ILST+1,LST(ILST)="~Schedule"  D SCHED
     27 S ILST=ILST+1,LST(ILST)="~Guideline" D GUIDE
     28 S ILST=ILST+1,LST(ILST)="~Message"   D OIMSG
     29 S ILST=ILST+1,LST(ILST)="~DEASchedule" ;PKI
     30 ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI
     31 S ILST=ILST+1,LST(ILST)="d" ;PKI
     32 I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D
     33 . I '$L(X2) Q
     34 . I $G(PKIACTIV)="Y" S X=X2
     35 S LST(ILST)=LST(ILST)_X
     36 I PSTYPE="U" D
     37 . ; start, expires, next admin
     38 I PSTYPE="O" D
     39 . ; days supply, quantity, refills
     40 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
     41 Q
     42 ;
     43PTINSTR ; from OISLCT, set up patient instructions
     44 N I
     45 S I=0 F  S I=$O(ORDOSE("PI",I)) Q:I'>0  S ILST=ILST+1,LST(ILST)="t"_ORDOSE("PI",I)
     46 Q
     47DOSAGE ; from OISLCT, set up the list of dosages
     48 ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
     49 ; must be called after ALLDOSE so ORWDOSES is set up
     50 N I
     51 S I=0 F  S I=$O(ORWDOSES(I)) Q:I'>0  S ILST=ILST+1,LST(ILST)=ORWDOSES(I)
     52 Q
     53DISPLST ; from OISLCT, set up list of dispense drugs
     54 ; DrugIEN^Strength^Units^Name^Split
     55 N DD
     56 S DD=0 F  S DD=$O(ORDOSE("DD",DD)) Q:'DD  D
     57 . S ILST=ILST+1
     58 . S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11)
     59 Q
     60ALLDOSE ; from OISLCT, set up a list of all possible doses
     61 ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
     62 N I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X
     63 S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0
     64 S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" "
     65 S I=0 F  S I=$O(ORDOSE(I)) Q:I'>0  D
     66 . S X=$$BLDDOSE(ORDOSE(I))
     67 . S ORWDOSES=ORWDOSES+1,ORWDOSES(ORWDOSES)=X
     68 . S ILST=ILST+1
     69 . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
     70 . S J=0 F  S J=$O(ORDOSE(I,J)) Q:J'>0  D
     71 . . S X=$$BLDDOSE(ORDOSE(I,J))
     72 . . S ILST=ILST+1
     73 . . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
     74 Q
     75BLDDOSE(X) ; build dose info where X is ORDOSE node
     76 ; from ALLDOSE
     77 ;    X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN
     78 ;    Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^
     79 ;      DoseText^CostText^MaxRefills^DispUnits^CanSplit
     80 ; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^
     81 ; No TotalDose,           use LocalDose
     82 ; TotalDose & Strength,   use LocalDose+Conjunction+Strength+Units
     83 ; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName
     84 S DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD),DDNM=$P(DRUG,U),ID=$P(X,U,1,6)
     85 S LDOSE=$P(X,U,5),TEXT=LDOSE,STREN=$P(DRUG,U,5)_$P(DRUG,U,6)
     86 S $P(ID,U,7)=$P(DRUG,U,5) S $P(ID,U,8)=$P(DRUG,U,6) ; add strength
     87 I '$L($P(X,U)),$L($P(DRUG,U,5))  S TEXT=TEXT_CONJ_STREN
     88 I '$L($P(X,U)),'$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_$P(DRUG,U)
     89 S UD=$P(X,U,3),COST=$P(X,U,7),NF=$S($P(DRUG,U,3):"NF",1:"")
     90 ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4)
     91 S Y="i"_DDNM_U_STREN_U_NF_U_$TR(ID,U,"&")_U_TEXT_U_COST_U_$P(DRUG,U,8)_U_$P(DRUG,U,4)
     92 Q Y
     93ROUTE ; from OISLCT, get list of routes for the drug form
     94 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
     95 N I,CNT,ABBR,IEN,ROUT,EXP,X
     96 S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
     97 . S X=^TMP("PSJMR",$J,I)
     98 . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
     99 . S ILST=ILST+1,LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$P(X,U,5)
     100 . I $P(X,U,6)="D",IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
     101 ; add abbreviations to list of routes, commented out for 15.5 on
     102 ; S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
     103 ; . S X=^TMP("PSJMR",$J,I)
     104 ; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
     105 ; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP
     106 Q
     107SCHED ; from OISLCT, get default schedule for this medication
     108 I $L($G(^TMP("PSJSCH",$J))) S ILST=ILST+1,LST(ILST)="d"_^($J)
     109 Q
     110GUIDE ; from OISLCT, get guidelines associated with this medication
     111 N IEN,I
     112 S IEN=0 F  S IEN=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN)) Q:'IEN  D
     113 . S I=0 F  S I=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)) Q:'I  D
     114 . . S ILST=ILST+1,LST(ILST)="t"_^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)
     115 Q
     116OIMSG ; from OISLCT, get the orderable item message for this medication
     117 S I=0 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  S ILST=ILST+1,LST(ILST)="t"_^(I,0)
     118 Q
     119ADMIN(REC,DFN,SCH,OI,LOC) ; return administration time info
     120 ; REC: StartText^StartTime^Duration^FirstAdmin
     121 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2)
     122 S LOC=+$G(^SC(LOC,42)),REC=""
     123 I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH)
     124 Q
     125REQST(VAL,DFN,SCH,OI,LOC,TXT) ; return requested start time
     126 ; VAL: FirstAdmin time
     127 S VAL=""
     128 Q:'$L($G(SCH))  Q:'$G(OI)
     129 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2)
     130 S LOC=+$G(^SC(LOC,42))
     131 S VAL=$P($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2)
     132 Q
     133DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) ; return qty for days supply
     134 ; VAL: quantity
     135 N ORWX,I,X,ADUR,ADURNM
     136 S ORWX("DAYS SUPPLY")=DAY
     137 S ORWX("PATIENT")=PAT
     138 I DRG S ORWX("DRUG")=DRG
     139 F I=1:1:$L(UPD,U)-1 D
     140 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
     141 . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
     142 . S ADUR=$P(DUR,U,I),ADURNM=$P($P(ADUR," ",2),"~")
     143 . S:ADURNM="MONTHS" X=+ADUR_"L"
     144 . S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2))
     145 . I $L(X) S ORWX("DURATION",I)=X
     146 . S X=$E($P(ADUR,"~",2))
     147 . I $L(X) S ORWX("CONJUNCTION",I)=X
     148 D QTYX^PSOSIG(.ORWX)
     149 S VAL=$G(ORWX("QTY"))
     150 Q
     151QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) ; return days supply given quantity
     152 ; VAL: days supply
     153 N ORWX,I,X,ADUR
     154 S ORWX("QTY")=QTY
     155 S ORWX("PATIENT")=PAT
     156 I DRG S ORWX("DRUG")=DRG
     157 F I=1:1:$L(UPD,U)-1 D
     158 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)
     159 . S ORWX("SCHEDULE",I)=$P(SCH,U,I)
     160 . S ADUR=$P(DUR,U,I),X=+ADUR_$E($P(ADUR," ",2))
     161 . I $L(X) S ORWX("DURATION",I)=X
     162 . S X=$E($P(ADUR,"~",2))
     163 . I $L(X) S ORWX("CONJUNCTION",I)=X
     164 D QTYX^PSOSIG(.ORWX)
     165 S VAL=$G(ORWX("DAYS SUPPLY"))
     166 Q
     167MAXREF(VAL,PAT,DRG,SUP,OI,OUT) ; return the maximum number of refills
     168 ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item
     169 ; VAL: maximum refills allowed
     170 N ORWX
     171 S ORWX("PATIENT")=PAT
     172 I $G(DRG) S ORWX("DRUG")=+DRG
     173 I $G(SUP) S ORWX("DAYS SUPPLY")=SUP
     174 I $G(OI)  S ORWX("ITEM")=+$P(^ORD(101.43,+OI,0),U,2)
     175 I $G(OUT) S ORWX("DISCHARGE")=1
     176 D MAX^PSOSIGDS(.ORWX)
     177 S VAL=$G(ORWX("MAX"))
     178 Q
     179SCHREQ(VAL,OI,RTE,DRG) ; return 1 if schedule is required
     180 ; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug
     181 S VAL=1
     182 Q:'$G(OI)  Q:'$G(RTE)
     183 S VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$G(DRG))
     184 Q
     185CHKPI(VAL,ODIFN) ; return pre-existing patient instruct
     186 N IDNUM,IDPI
     187 S (IDNUM,IDPI)=0,VAL=""
     188 I '$D(^OR(100,ODIFN,4.5,"ID","PI")) S VAL="" Q
     189 F  S IDNUM=$O(^OR(100,ODIFN,4.5,"ID","PI",IDNUM)) Q:'IDNUM  D
     190 . F  S IDPI=$O(^OR(100,ODIFN,4.5,IDNUM,2,IDPI)) Q:'IDPI  D
     191 .. S VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0)
     192 K IDNUM,IDPI
     193 Q
     194CHKGRP(VAL,ORIFN) ;
     195 ;Inpatient Med Order Group or Clin Meds Group: return 1
     196 ;If order belong to Outpatient Med Order Grpoup: return 2
     197 ;Otherwise, return 0
     198 S VAL=0
     199 I '$L(ORIFN) Q
     200 N UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED
     201 S ODID=+ORIFN
     202 Q:ODID<1
     203 S (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0
     204 S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP))
     205 S OPGRP=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP))
     206 S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
     207 S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
     208 S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP))
     209 I $L($G(^OR(100,ODID,0)))<1 Q
     210 S ODGRP=$P(^OR(100,ODID,0),U,11)
     211 I (UDGRP=ODGRP)!(CLMED=ODGRP) S VAL=1
     212 I IPGRP=ODGRP S VAL=1
     213 I OPGRP=ODGRP S VAL=2
     214 K UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED
     215 Q
     216QOGRP(VAL,QOIFN) ;
     217 ;If quick order belong to Inpatient Med Order Group: return 1
     218 ;Otherwise, return 0
     219 S VAL=0
     220 I '$L(QOIFN) Q
     221 N UDGRP,IPGRP,QOGRP,QOID,CLMED
     222 S QOID=+QOIFN
     223 Q:QOID<1
     224 S (UDGRP,IPGRP,QOGRP,CLMED)=0
     225 S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP))
     226 S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
     227 S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
     228 S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP))
     229 I $L($G(^ORD(101.41,QOID,0)))<1 Q
     230 S QOGRP=$P(^ORD(101.41,QOID,0),U,5)
     231 I UDGRP=QOGRP S VAL=1
     232 I (IPGRP=QOGRP)!(CLMED=QOGRP) S VAL=1
     233 K UDGRP,QOGRP,QOID,IPGRP,CLMED
     234 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m

    r613 r623  
    1 ORWDPS32        ; SLC/KCM - Pharmacy Calls for GUI Dialog ; 02/11/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,243**;Dec 17, 1997;Build 242
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 NXT()   ; -- ret next available index in data array
    5         S ILST=ILST+1
    6         Q ILST
    7         ;
    8 DLGSLCT(LST,PSTYPE,DFN,LOCIEN)  ; return def lists for dialog
    9         ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt)
    10         N ILST S ILST=0
    11         I PSTYPE="F" D  Q                       ; IV Fluids
    12         . S LST($$NXT)="~ShortList"  D SHORT
    13         . S LST($$NXT)="~Priorities" D PRIOR
    14         . ;S LST($$NXT)="~Schedules"  D SCHED(LOCIEN)
    15         . S LST($$NXT)="~Route" D IVROUTE
    16         ;
    17         S LST($$NXT)="~ShortList"  D SHORT      ; Unit Dose & Outpt
    18         ;S LST($$NXT)="~Schedules"  D SCHED(LOCIEN)
    19         S LST($$NXT)="~Priorities" D PRIOR
    20         I PSTYPE="O" D                          ; Outpt
    21         . S LST($$NXT)="~Pickup"   D PICKUP
    22         . S LST($$NXT)="~SCStatus" D SCLIST
    23         Q
    24 SHORT   ; from DLGSLCT, get short list of med quick orders
    25         ; !!! change this so that it uses the ORWDXQ call!!!
    26         N I,X,TMP
    27         I PSTYPE="U" S X="UD RX"
    28         I PSTYPE="F" S X="IV RX"
    29         I PSTYPE="O" S X="O RX"
    30         D GETQLST^ORWDXQ(.TMP,X,"iQ")
    31         S I=0 F  S I=$O(TMP(I)) Q:'I  S LST($$NXT)=TMP(I)
    32         Q
    33 SCHEDA  ; (similar to SCHED, but also rtns admin times)
    34         N X,IEN,SCH,TIME
    35         K ^TMP($J,"ORWDPS32 SCHEDA")
    36         D AP^PSS51P1("PSJ",,,,"ORWDPS32 SCHEDA")
    37         S SCH="" F  S SCH=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH)) Q:SCH=""  D
    38         .S IEN="" F  S IEN=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0  D
    39         ..S TIME=$G(^TMP($J,"ORWDPS32 SCHEDA",IEN,1))
    40         ..S X=$S($L(TIME):"  ("_TIME_")",1:"")
    41         ..S LST($$NXT)="i"_IEN_U_SCH_U_X
    42         K ^TMP($J,"ORWDPS32 SCHEDA")
    43         Q
    44         ;
    45 IVROUTE ;
    46         N ABB,EXP,IEN,RTE
    47         K ^TMP($J,"ORWDPS32 IVROUTE")
    48         D ALL^PSS51P2(,"??",,1,"ORWDPS32 IVROUTE")
    49         S RTE="" F  S RTE=$O(^TMP($J,"ORWDPS32 IVROUTE","B",RTE)) Q:RTE=""  D
    50         .S IEN=$O(^TMP($J,"ORWDPS32 IVROUTE","IV",RTE,"")) Q:IEN'>0
    51         .S ABB=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,1))
    52         .S EXP=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,4))
    53         .S LST($$NXT)="i"_IEN_U_RTE_U_ABB_U_EXP
    54         K ^TMP($J,"ORWDPS32 IVROUTE")
    55         Q
    56         ;
    57 ALLIVRTE(LST)   ;
    58         N ABB,CNT,EXP,IEN,RTE
    59         K ^TMP($J,"ORWDPS32 ALLIVRTE")
    60         S CNT=0
    61         D ALL^PSS51P2(,"??",,1,"ORWDPS32 ALLIVRTE")
    62         S RTE="" F  S RTE=$O(^TMP($J,"ORWDPS32 ALLIVRTE","B",RTE)) Q:RTE=""  D
    63         .S IEN=$O(^TMP($J,"ORWDPS32 ALLIVRTE","IV",RTE,"")) Q:IEN'>0
    64         .S ABB=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,1))
    65         .S EXP=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,4))
    66         .S CNT=CNT+1,LST(CNT)=IEN_U_RTE_U_ABB_U_U_U_U
    67         K ^TMP($J,"ORWDPS32 IVROUTE")
    68         Q
    69         ;
    70 ROUTE   ; from OISLCT^ORWDPS32, get list of routes for the drug form
    71         ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
    72         N I,CNT,ABBR,IEN,ROUT,X
    73         S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
    74         . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
    75         . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
    76         . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
    77         S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
    78         . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
    79         . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
    80         Q
    81         ;similar to SCHED^ORWDPS32, also returns Admin Time for Patient ward location
    82         ;AGP CPRS 27.72 THIS CODE IS NOT NEEDED ANYMORE
    83 SCHED(LOCIEN)   ;
    84         N CNT,ORARRAY,SCH,IEN,EXP,TIME,TYP,X0,WIEN
    85         ;K ^TMP($J,"ORWDPS32 SCHED1")
    86         S WIEN=$$WARDIEN(+LOCIEN)
    87         D SCHED^PSS51P1(WIEN,.ORARRAY)
    88         S CNT=0 F  S CNT=$O(ORARRAY(CNT)) Q:CNT'>0  D
    89         .S LST($$NXT)="i"_$P(ORARRAY(CNT),U,2,5)
    90         Q
    91         ;
    92 WARDIEN(LOCIEN) ;
    93         N RESULT
    94         S RESULT=0
    95         I LOCIEN=0 Q RESULT
    96         I $P($G(^SC(LOCIEN,42)),U)="" Q RESULT
    97         S RESULT=+$P($G(^SC(LOCIEN,42)),U)
    98         Q RESULT
    99 PRIOR   ; from DLGSLCT, get list of allowed priorities
    100         N X,XREF
    101         S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")
    102         S X="" F  S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X)  D
    103         . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
    104         S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
    105         Q
    106 PICKUP  ; from DLGSLCT, get prescription routing
    107         N X,EDITONLY
    108         F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
    109         S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
    110         Q
    111 DEFPICK()             ; ret def routing
    112         N X,DLG,PRMT
    113         S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
    114         S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
    115         I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
    116         I X'="" S EDITONLY=1 Q X  ; EDITONLY used by def action
    117         ;
    118         S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
    119         I X="C" S X="C^in Clinic" G XPICK
    120         I X="M" S X="M^by Mail"   G XPICK
    121         I X="W" S X="W^at Window" G XPICK
    122         I X="N" S X=""             G XPICK
    123         I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
    124 XPICK   Q X
    125         ;
    126 SCLIST  ; from DLGSLCT, get options for service connected
    127         F X="0^No","1^Yes" S LST($$NXT)="i"_X
    128         Q
    129         ;
    130 OISLCT(LST,OI,PSTYPE,ORVP)      ; rtn for defaults for pharm OI
    131         N ILST S ILST=0
    132         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    133         S LST($$NXT)="~Dispense" D DISPDRG
    134         S LST($$NXT)="~Instruct" D INSTRCT
    135         S LST($$NXT)="~Route"    D ROUTE
    136         S LST($$NXT)="~Message"  D MESSAGE
    137         I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
    138         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
    139         Q
    140         ;
    141 DISPDRUG(LST,OI)        ; list dispense drugs for an OI
    142         N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
    143         Q
    144         ;
    145 DISPDRG ; from OISLCT, get disp drugs for this pharm OI
    146         N I,ORTMP,ORX
    147         S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
    148         I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
    149         I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
    150         S I="" F  S I=$O(ORTMP(I)) Q:I=""  D
    151         . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
    152         . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
    153         . S LST($$NXT)="i"_ORTMP(I)
    154         Q
    155 INSTRCT ; from OISLCT, get list of potential instructs (based on drug form)
    156         N INOUN,NOUN,IINS,INS,VERB,INSREC
    157         D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
    158         I PSTYPE="U" Q  ; don't use the instructions list for inpatients
    159         S IINS=0 F  S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS  D
    160         . S INSREC=$G(^TMP("PSJINS",$J,IINS))
    161         . I '$D(VERB) S VERB=$P(INSREC,U)
    162         . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
    163         S LST($$NXT)="~Nouns"
    164         S INOUN=0 F  S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN  D
    165         . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
    166         I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
    167         ;
    168         Q
    169 MIXED(X)          ; Return mixed case
    170         Q X
    171         ;
    172 MESSAGE ; message
    173         S I=0 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  S LST($$NXT)="t"_^(I,0)
    174         Q
    175 ALLROUTE(LST)   ; returns a list of all available med routes
    176         N I,X,ILST
    177         S ILST=0
    178         K ^TMP($J,"ORWDPS32 ALLROUTE")
    179         D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
    180         S I=0 F  S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I  D
    181         . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1)
    182         K ^TMP($J,"ORWDPS32 ALLROUTE")
    183         Q
    184 VALROUTE(REC,X)        ; validates route name & returns IEN + abbreviation
    185         N ABBR,NAME,IEN
    186         K ^TMP($J,"ORWDPS32 VALROUTE")
    187         S X=$$UPPER(X)
    188         D ALL^PSS51P2(,X,,1,"ORWDPS32 VALROUTE")
    189         I $P(^TMP($J,"ORWDPS32 VALROUTE",0),U)=-1 K ^TMP($J,"ORWDPS32 VALROUTE") S REC=0 Q
    190         S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","B",X,""))
    191         I IEN'>0 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","C",X,""))
    192         I IEN'>0 S REC=0 Q
    193         S NAME=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,.01))
    194         S ABBR=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,1))
    195         I '$L(ABBR) S ABBR=NAME
    196         I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORWDPS32 VALROUTE") Q
    197         S REC=IEN_U_ABBR
    198         K ^TMP($J,"ORWDPS32 VALROUTE")
    199         Q
    200 AUTH(VAL,PRV)   ; For inpatient meds, check restrictions
    201         N NAME,AUTH,INACT,X S VAL=0
    202         S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
    203         S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
    204         I 'AUTH!(INACT&(DT>INACT)) D  Q
    205         . S VAL="1^"_NAME_" is not authorized to write medication orders."
    206         I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D  Q
    207         . S VAL="1^OREMAS key holders may not enter medication orders."
    208         Q
    209 AUTHNVA(VAL,PRV)        ; For Non-VA meds, check restrictions
    210         N NAME,AUTH,INACT,X S VAL=0
    211         I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q
    212         I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D  Q
    213         . S VAL="1^OREMAS key holders may not enter non-VA medication orders."
    214         S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
    215         S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
    216         I 'AUTH!(INACT&(DT>INACT)) D  Q
    217         . S VAL="1^"_NAME_" is not authorized to write medication orders."
    218         Q
    219         ;
    220 UPPER(X)               ; return uppercase
    221         Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    222         ;
    223 TRIM(X) ; trim leading and trailing spaces
    224         S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;trail
    225         S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;lead
    226         Q X
    227         ;
     1ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;08/04/96
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,237**;Dec 17, 1997
     3 ;
     4NXT() ; -- ret next available index in data array
     5 S ILST=ILST+1
     6 Q ILST
     7 ;
     8DLGSLCT(LST,PSTYPE) ; return def lists for dialog
     9 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt)
     10 N ILST S ILST=0
     11 I PSTYPE="F" D  Q                       ; IV Fluids
     12 . S LST($$NXT)="~ShortList"  D SHORT
     13 . S LST($$NXT)="~Priorities" D PRIOR
     14 ;
     15 S LST($$NXT)="~ShortList"  D SHORT      ; Unit Dose & Outpt
     16 S LST($$NXT)="~Schedules"  D SCHED
     17 S LST($$NXT)="~Priorities" D PRIOR
     18 I PSTYPE="O" D                          ; Outpt
     19 . S LST($$NXT)="~Pickup"   D PICKUP
     20 . S LST($$NXT)="~SCStatus" D SCLIST
     21 Q
     22SHORT ; from DLGSLCT, get short list of med quick orders
     23 ; !!! change this so that it uses the ORWDXQ call!!!
     24 N I,X,TMP
     25 I PSTYPE="U" S X="UD RX"
     26 I PSTYPE="F" S X="IV RX"
     27 I PSTYPE="O" S X="O RX"
     28 D GETQLST^ORWDXQ(.TMP,X,"iQ")
     29 S I=0 F  S I=$O(TMP(I)) Q:'I  S LST($$NXT)=TMP(I)
     30 Q
     31SCHED ; from DLGSLCT, get all pharm admin scheds
     32 N X
     33 S X="" F  S X=$O(^PS(51.1,"APPSJ",X)) Q:X=""  S LST($$NXT)="i"_X
     34 Q
     35SCHEDA ; (similar to SCHED, but also rtns admin times)
     36 N X,IEN,SCH
     37 S SCH="" F  S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH=""  D
     38 . S IEN=0 F  S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0  D
     39 . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):"  ("_$P(X,U,2)_")",1:"")
     40 . . S LST($$NXT)="i"_IEN_U_SCH_X
     41 Q
     42PRIOR ; from DLGSLCT, get list of allowed priorities
     43 N X,XREF
     44 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")
     45 S X="" F  S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X)  D
     46 . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
     47 S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
     48 Q
     49PICKUP ; from DLGSLCT, get prescription routing
     50 N X,EDITONLY
     51 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
     52 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
     53 Q
     54DEFPICK()       ; ret def routing
     55 N X,DLG,PRMT
     56 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
     57 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
     58 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
     59 I X'="" S EDITONLY=1 Q X  ; EDITONLY used by def action
     60 ;
     61 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
     62 I X="C" S X="C^in Clinic" G XPICK
     63 I X="M" S X="M^by Mail"   G XPICK
     64 I X="W" S X="W^at Window" G XPICK
     65 I X="N" S X=""             G XPICK
     66 I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
     67XPICK Q X
     68 ;
     69SCLIST ; from DLGSLCT, get options for service connected
     70 F X="0^No","1^Yes" S LST($$NXT)="i"_X
     71 Q
     72 ;
     73OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI
     74 N ILST S ILST=0
     75 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     76 S LST($$NXT)="~Dispense" D DISPDRG
     77 S LST($$NXT)="~Instruct" D INSTRCT
     78 S LST($$NXT)="~Route"    D ROUTE
     79 S LST($$NXT)="~Message"  D MESSAGE
     80 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
     81 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
     82 Q
     83 ;
     84DISPDRUG(LST,OI) ; list dispense drugs for an OI
     85 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
     86 Q
     87 ;
     88DISPDRG ; from OISLCT, get disp drugs for this pharm OI
     89 N I,ORTMP,ORX
     90 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
     91 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
     92 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
     93 S I="" F  S I=$O(ORTMP(I)) Q:I=""  D
     94 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
     95 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
     96 . S LST($$NXT)="i"_ORTMP(I)
     97 Q
     98INSTRCT ; from OISLCT, get list of potential instructs (based on drug form)
     99 N INOUN,NOUN,IINS,INS,VERB,INSREC
     100 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
     101 I PSTYPE="U" Q  ; don't use the instructions list for inpatients
     102 S IINS=0 F  S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS  D
     103 . S INSREC=$G(^TMP("PSJINS",$J,IINS))
     104 . I '$D(VERB) S VERB=$P(INSREC,U)
     105 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
     106 S LST($$NXT)="~Nouns"
     107 S INOUN=0 F  S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN  D
     108 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
     109 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
     110 ;
     111 Q
     112MIXED(X)   ; Return mixed case
     113 Q X  ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
     114 ;
     115ROUTE ; from OISLCT, get list of routes for the drug form
     116 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
     117 N I,CNT,ABBR,IEN,ROUT,X
     118 S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
     119 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
     120 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
     121 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
     122 S I="" F  S I=$O(^TMP("PSJMR",$J,I)) Q:I=""  D
     123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
     124 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
     125 Q
     126MESSAGE ; message
     127 S I=0 F  S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0  S LST($$NXT)="t"_^(I,0)
     128 Q
     129ALLROUTE(LST) ; returns a list of all available med routes
     130 N I,X,ILST S ILST=0
     131 S I=0 F  S I=$O(^PS(51.2,I)) Q:'I  S X=^(I,0) D
     132 . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3)
     133 Q
     134VALROUTE(REC,X)        ; validates route name & returns IEN + abbreviation
     135 N ORLST,ABBR
     136 D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST")
     137 I 'ORLST("DILIST",0) S REC=0 Q
     138 S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1)
     139 I '$L(ABBR) S ABBR=ORLST("DILIST",1,1)
     140 I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q
     141 S REC=ORLST("DILIST",2,1)_U_ABBR
     142 Q
     143AUTH(VAL,PRV) ; For inpatient meds, check restrictions
     144 N NAME,AUTH,INACT,X S VAL=0
     145 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
     146 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
     147 I 'AUTH!(INACT&(DT>INACT)) D  Q
     148 . S VAL="1^"_NAME_" is not authorized to write medication orders."
     149 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D  Q
     150 . S VAL="1^OREMAS key holders may not enter medication orders."
     151 Q
     152AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions
     153 N NAME,AUTH,INACT,X S VAL=0
     154 I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q
     155 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D  Q
     156 . S VAL="1^OREMAS key holders may not enter non-VA medication orders."
     157 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
     158 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
     159 I 'AUTH!(INACT&(DT>INACT)) D  Q
     160 . S VAL="1^"_NAME_" is not authorized to write medication orders."
     161 Q
     162DRUGMSG(VAL,IEN)        ; return any message associated with a dispense drug
     163 N X S X=$$ENDCM^PSJORUTL(IEN)
     164 S VAL=$P(X,U,2)_U_$P(X,U,4)
     165 Q
     166MEDISIV(VAL,IEN)        ; return true if orderable item is IV medication
     167 S VAL=0
     168 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
     169 Q
     170ISSPLY(VAL,IEN) ; return true if orderable item is a supply
     171 S VAL=0
     172 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
     173 Q
     174IVAMT(VAL,OI,ORWTYP)     ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
     175 N I,PSOI,ORWY,AMT
     176 S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)_ORWTYP,VAL=""
     177 D ENVOL^PSJORUT2(PSOI,.ORWY)
     178 I ORWTYP="B" D
     179 . S I=0 F  S I=$O(ORWY(I)) Q:I'>0  S AMT(+ORWY(I))=""
     180 . S AMT=0,VAL="ML" F  S AMT=$O(AMT(AMT)) Q:AMT'>0  S VAL=VAL_U_AMT
     181 I ORWTYP="A" D
     182 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
     183 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM"
     184 Q
     185VALRATE(VAL,X)   ; return "1" (true) if IV rate text is valid
     186 I $E($RE($$UPPER(X)),1,5)="RH/LM"  S X=$E(X,1,$L(X)-5)
     187 S X=$$TRIM(X)
     188 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0)
     189 Q
     190UPPER(X)        ; return uppercase
     191 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     192 ;
     193TRIM(X) ; trim leading and trailing spaces
     194 S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;trail
     195 S X=$RE(X) F  S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" "  Q:'$L(X)  ;lead
     196 Q X
     197SCSTS(VAL,ORVP,ORDRUG)  ; return service connected eligibility for patient
     198 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
     199 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
     200 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
     201 S VAL=1
     202XSCSTS Q
     203FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
     204 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
     205 S I=0 F  S I=$O(ORLST(I)) Q:'I  D
     206 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
     207 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
     208 Q
     209VALSCH(OK,X,PSTYPE)    ; validate a schedule, return 1 if valid, 0 if not
     210 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
     211 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
     212 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
     213 . K X S:$D(ORX) X=ORX
     214 E  D
     215 . D EN^PSSGSGUI
     216 S OK=$S($D(X):1,1:0)
     217 Q
     218VALQTY(OK,X)    ; validate a quantity, return 1 if valid, 0 if not
     219 ; to be compatible with LM, make sure X is integer from 1 to 240
     220 ; this is based on the input transform from 52,7
     221 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
     222 S OK=$S($D(X):1,1:0)
     223 Q
     224DOSES(LST,OI) ; return doses for an orderable item  -  TEST ONLY
     225 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O"
     226 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
     227 S ORI=0 F  S ORI=$O(ORTMP(ORI)) Q:'ORI  S ORWDRG=+ORTMP(ORI) D
     228 . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF
     229 . S X=$$DFSU^PSNAPIS(NDF,VAPN)
     230 . S LSTA($P(X,U,4),$P(X,U,6))=""
     231 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
     232 S ORI="",ILST=0 F  S ORI=$O(LSTA(ORI)) Q:ORI=""  D
     233 . S ORJ="" F  S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ=""  D
     234 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
     235 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m

    r613 r623  
    1 ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 CPLST(TEST,PTIFN,ORIFNS)        ; --Get CP questions
    5         N ORIFN,ORDA,ORI,ORPSO,CPX
    6         S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0))
    7         F  S ORI=$O(ORIFNS(ORI)) Q:'ORI  D
    8         .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2)
    9         .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D
    10         ..N PRIO S PRIO=0
    11         ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0))
    12         ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1))
    13         ..Q:PRIO=99
    14         ..S CPX=$$SC(ORIFN)
    15         ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX
    16         K PTIFN,ORIFN,ORDA,ORI,CPX
    17         Q
    18         ;
    19 CPINFO(Y,ORINFO)        ; -- Save reponses to CP questions
    20         Q:'$D(ORINFO)
    21         N ORIFN,ORI,ORX,ANS S ORI=0
    22         F  S ORI=$O(ORINFO(ORI)) Q:'ORI  D
    23         .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1)
    24         .S ANS=$P(ORINFO(ORI),U,2)
    25         .D REFMT(.ORX,ANS)
    26         .D SC^ORCSAVE2(.ORX,ORIFN)
    27         S Y=1
    28         K ORIFN,ORX,ORI,ANS
    29         Q
    30         ;
    31 SC(ORIFN)       ; -- Dialog validation, to ask CP questions
    32         ;Expects ORIFN and ORDA
    33         ;
    34         N DR S DR=""
    35         I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR
    36         I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR
    37         ;
    38         N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV,ASHD
    39         S ORX="",XACT=""
    40         ;--Only new, renew, edited, copied outpatient order can continue...
    41         ;AGP CHANGE 26.65, will returned service connection data for change orders
    42         S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR
    43         I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR
    44         I $D(^OR(100,ORIFN,5))>0 D
    45         .S CPNODE=$G(^OR(100,ORIFN,5))
    46         .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"")
    47         .S DR=$S($L(ASC):DR_U_ASC,1:DR)
    48         .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"")
    49         .S DR=$S($L(AAO):DR_U_AAO,1:DR)
    50         .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"")
    51         .S DR=$S($L(AIR):DR_U_AIR,1:DR)
    52         .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"")
    53         .S DR=$S($L(AEC):DR_U_AEC,1:DR)
    54         .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"")
    55         .S DR=$S($L(AMST):DR_U_AMST,1:DR)
    56         .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"")
    57         .S DR=$S($L(AHNC):DR_U_AHNC,1:DR)
    58         .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"")
    59         .S DR=$S($L(ACV):DR_U_ACV,1:DR)
    60         .S ASHD=$S($L($P(CPNODE,"^",8)):"SHD;"_$P(CPNODE,"^",8),1:"")
    61         .S DR=$S($L(ASHD):DR_U_ASHD,1:DR)
    62         .D CPCOMP(.DR)
    63         .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE
    64         I $L(DR)>0 Q DR
    65         I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal
    66         S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
    67         D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR
    68         F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D
    69         . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"")
    70         Q DR
    71 REFMT(ORX,INFO) ;
    72         ;"U": Unchecked ("NO")
    73         ;"C": Checked ("YES")
    74         ;"N" : Question not asked
    75         N RST,RST1
    76         S RST=""
    77         F I=1:1:$L(INFO)  S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"")
    78         S RST1=$E(RST,2,$L(RST))
    79         S ORX("SC")=$P(RST1,U,1)
    80         S ORX("MST")=$P(RST1,U,5)
    81         S ORX("AO")=$P(RST1,U,2)
    82         S ORX("IR")=$P(RST1,U,3)
    83         S ORX("EC")=$P(RST1,U,4)
    84         S ORX("HNC")=$P(RST1,U,6)
    85         S ORX("CV")=$P(RST1,U,7)
    86         S ORX("SHD")=$P(RST1,U,8)
    87         K RST,RST1
    88         Q
    89 CPCOMP(PREX)    ; -- Compare the existed exemptions with new exemption questions
    90         N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL
    91         S LSTCP=""
    92         S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
    93         D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q
    94         F CPI="SC","AO","IR","EC","MST","HNC","CV","SHD" D
    95         . I $D(ORX1(CPI)) D
    96         . . S TMPVAL=""
    97         . . I $F(PREX,CPI) D
    98         . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1)
    99         . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL
    100         . . . E  S TMPVAL=CPI
    101         . . E  S TMPVAL=CPI
    102         . . S LSTCP=LSTCP_U_TMPVAL
    103         S PREX=LSTCP
    104         Q
    105 IPOD4OP(ORY,ORID)       ;True: is an Inpt (IV OI) order on an OutPatient
    106         Q:'$D(^OR(100,+ORID,0))
    107         S ORY=0
    108         N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG
    109         S (RXDG,UDDLG,IPPKG)=0
    110         S RXDG=+$O(^ORD(100.98,"B","O RX",0))
    111         S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0))
    112         S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0))
    113         S ADLG=+$P($G(^OR(100,+ORID,0)),U,5)
    114         S ADG=$P($G(^OR(100,+ORID,0)),U,11)
    115         S APKG=$P($G(^OR(100,+ORID,0)),U,14)
    116         S APTCLS=$P($G(^OR(100,+ORID,0)),U,12)
    117         I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1
    118         Q
    119         ;
    120 UPDTDG(ORY,ORID)        ;Update Inpt order for outpatient DG to Inpt DG
    121         Q:'$D(^OR(100,+ORID,0))
    122         N UDDG
    123         S UDDG=$O(^ORD(100.98,"B","UD RX",0))
    124         S $P(^OR(100,+ORID,0),U,11)=UDDG
    125         Q
    126 ISUDIV(ORY,ORIFN)       ;True: OI of the order is for both UD and IV
    127         N OI
    128         S (OI,ORY)=0
    129         S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1
    130         I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1
    131         Q
     1ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215**;Dec 17, 1997
     3 ;
     4CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions
     5 N ORIFN,ORDA,ORI,ORPSO,CPX
     6 S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0))
     7 F  S ORI=$O(ORIFNS(ORI)) Q:'ORI  D
     8 .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2)
     9 .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D
     10 ..N PRIO S PRIO=0
     11 ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0))
     12 ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1))
     13 ..Q:PRIO=99
     14 ..S CPX=$$SC(ORIFN)
     15 ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX
     16 K PTIFN,ORIFN,ORDA,ORI,CPX
     17 Q
     18 ;
     19CPINFO(Y,ORINFO) ; -- Save reponses to CP questions
     20 Q:'$D(ORINFO)
     21 N ORIFN,ORI,ORX,ANS S ORI=0
     22 F  S ORI=$O(ORINFO(ORI)) Q:'ORI  D
     23 .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1)
     24 .S ANS=$P(ORINFO(ORI),U,2)
     25 .D REFMT(.ORX,ANS)
     26 .D SC^ORCSAVE2(.ORX,ORIFN)
     27 S Y=1
     28 K ORIFN,ORX,ORI,ANS
     29 Q
     30 ;
     31SC(ORIFN) ; -- Dialog validation, to ask CP questions
     32 ;Expects ORIFN and ORDA
     33 ;
     34 N DR S DR=""
     35 I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR
     36 I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR
     37 ;
     38 N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV
     39 S ORX="",XACT=""
     40 ;--Only new, renew, edited, copied outpatient order can continue...
     41 ;AGP CHANGE 26.65, will returned service connection data for change orders
     42 S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR
     43 I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR
     44 I $D(^OR(100,ORIFN,5))>0 D
     45 .S CPNODE=$G(^OR(100,ORIFN,5))
     46 .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"")
     47 .S DR=$S($L(ASC):DR_U_ASC,1:DR)
     48 .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"")
     49 .S DR=$S($L(AAO):DR_U_AAO,1:DR)
     50 .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"")
     51 .S DR=$S($L(AIR):DR_U_AIR,1:DR)
     52 .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"")
     53 .S DR=$S($L(AEC):DR_U_AEC,1:DR)
     54 .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"")
     55 .S DR=$S($L(AMST):DR_U_AMST,1:DR)
     56 .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"")
     57 .S DR=$S($L(AHNC):DR_U_AHNC,1:DR)
     58 .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"")
     59 .S DR=$S($L(ACV):DR_U_ACV,1:DR)
     60 .D CPCOMP(.DR)
     61 .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE
     62 I $L(DR)>0 Q DR
     63 I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal
     64 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
     65 D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR
     66 F I="SC","AO","IR","EC","MST","HNC","CV" D
     67 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"")
     68 Q DR
     69REFMT(ORX,INFO) ;
     70 ;"U": Unchecked ("NO")
     71 ;"C": Checked ("YES")
     72 ;"N" : Question not asked
     73 N RST,RST1
     74 S RST=""
     75 F I=1:1:$L(INFO)  S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"")
     76 S RST1=$E(RST,2,$L(RST))
     77 S ORX("SC")=$P(RST1,U,1)
     78 S ORX("MST")=$P(RST1,U,5)
     79 S ORX("AO")=$P(RST1,U,2)
     80 S ORX("IR")=$P(RST1,U,3)
     81 S ORX("EC")=$P(RST1,U,4)
     82 S ORX("HNC")=$P(RST1,U,6)
     83 S ORX("CV")=$P(RST1,U,7)
     84 K RST,RST1
     85 Q
     86CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions
     87 N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL
     88 S LSTCP=""
     89 S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
     90 D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q
     91 F CPI="SC","AO","IR","EC","MST","HNC","CV" D
     92 . I $D(ORX1(CPI)) D
     93 . . S TMPVAL=""
     94 . . I $F(PREX,CPI) D
     95 . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1)
     96 . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL
     97 . . . E  S TMPVAL=CPI
     98 . . E  S TMPVAL=CPI
     99 . . S LSTCP=LSTCP_U_TMPVAL
     100 S PREX=LSTCP
     101 Q
     102IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient
     103 Q:'$D(^OR(100,+ORID,0))
     104 S ORY=0
     105 N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG
     106 S (RXDG,UDDLG,IPPKG)=0
     107 S RXDG=+$O(^ORD(100.98,"B","O RX",0))
     108 S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0))
     109 S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0))
     110 S ADLG=+$P($G(^OR(100,+ORID,0)),U,5)
     111 S ADG=$P($G(^OR(100,+ORID,0)),U,11)
     112 S APKG=$P($G(^OR(100,+ORID,0)),U,14)
     113 S APTCLS=$P($G(^OR(100,+ORID,0)),U,12)
     114 I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1
     115 Q
     116 ;
     117UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG
     118 Q:'$D(^OR(100,+ORID,0))
     119 N UDDG
     120 S UDDG=$O(^ORD(100.98,"B","UD RX",0))
     121 S $P(^OR(100,+ORID,0),U,11)=UDDG
     122 Q
     123ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV
     124 N OI
     125 S (OI,ORY)=0
     126 S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1
     127 I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1
     128 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDVAL.m

    r613 r623  
    1 ORWDVAL ; SLC/KCM - Validate procedures
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
    3         ;
    4 VALSCHED(ERR,SCHED)     ; Validate a schedule
    5         ; Set up 'interval^repeat count', if no interval assume QD
    6         S ERR=0
    7         S INTERVAL=$P(SCHED," ",1),REPEAT=$P(SCHED," ",2)
    8         ;I '$O(^PS(51.1,"APLR",INTERVAL,0)) S ERR=1 Q
    9         K ^TMP($J,"ORLIST")
    10         D ZERO^PSS51P1(,INTERVAL,"LR",,"ORLIST")
    11         I '$D(^TMP($J,"ORLIST","B",INTERVAL)) K ^TMP($J,"ORLIST") S ERR=1 Q
    12         K ^TMP($J,"ORLIST")
    13         I '(X?1"X"1.N) S ERR=1 Q
    14         Q
    15 STOPDT(ADATE,SCHED)     ; Return stop date given a schedule
    16         ; Look at max days continuous orders
    17         ; set numdays to lesser of Xnn and LR MAX...
    18         ; calculate stop date from collection time
    19         Q
    20 EXPSCHED(LST,SCHED,START,STOP,MAX)      ; procedure
    21         ; Expand schedule into start/stop times
    22         N IEN,TYP,INTERVAL,REPEAT
    23         D VALSCHED I ERR S LST=""
    24         S INTERVAL=$P(SCHED," ",1),REPEAT=$E($P(SCHED," ",2),2,999)
    25         K ^TMP($J,"ORWDVAL") D AP^PSS51P1("LR",INTERVAL,,,"ORWDVAL")
    26         S IEN=$O(^TMP($J,"ORWDVAL","APLR",INTERVAL,0))
    27         S TYP=$P($G(^TMP($J,"ORWDVAL",IEN,5)),U)
    28         S FREQ=$G(^TMP($J,"ORWDVAL",IEN,2))
    29         I TYP="C" D  ; add interval until repeat count or stop time reached
    30         . ;
    31         I TYP="D" D  ; from start time look for matching day of week & add
    32         . ;
    33         I TYP="O" D  ; quit with just the start time
    34         . ;
    35         ; range, shift, dow-range ???
    36         K ^TMP($J,"ORWDVAL")
    37         Q
    38 DATE    ; Validate a date/time (allow visits)
    39         Q
     1ORWDVAL ; SLC/KCM - Validate procedures
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
     3 ;
     4VALSCHED(ERR,SCHED) ; Validate a schedule
     5 ; Set up 'interval^repeat count', if no interval assume QD
     6 S ERR=0
     7 S INTERVAL=$P(SCHED," ",1),REPEAT=$P(SCHED," ",2)
     8 I '$O(^PS(51.1,"APLR",INTERVAL,0)) S ERR=1 Q
     9 I '(X?1"X"1.N) S ERR=1 Q
     10 Q
     11STOPDT(ADATE,SCHED) ; Return stop date given a schedule
     12 ; Look at max days continuous orders
     13 ; set numdays to lesser of Xnn and LR MAX...
     14 ; calculate stop date from collection time
     15 Q
     16EXPSCHED(LST,SCHED,START,STOP,MAX) ; procedure
     17 ; Expand schedule into start/stop times
     18 N IEN,TYP,INTERVAL,REPEAT
     19 D VALSCHED I ERR S LST=""
     20 S INTERVAL=$P(SCHED," ",1),REPEAT=$E($P(SCHED," ",2),2,999)
     21 S IEN=$O(^PS(51.1,"APLR",INTERVAL,0))
     22 S TYP=$P(^PS(51.1,IEN,0),U,5),FREQ=$P(^(0),U,3)
     23 I TYP="C" D  ; add interval until repeat count or stop time reached
     24 . ;
     25 I TYP="D" D  ; from start time look for matching day of week & add
     26 . ;
     27 I TYP="O" D  ; quit with just the start time
     28 . ;
     29 ; range, shift, dow-range ???
     30 Q
     31DATE ; Validate a date/time (allow visits)
     32 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m

    r613 r623  
    1 ORWDX   ; SLC/KCM/REV/JLI - Order dialog utilities ;11/28/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,246,243**;Dec 17, 1997;Build 242
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items
    6         ; Y(n)=IEN^.01 Name^.01 Name  -or-  IEN^Synonym <.01 Name>^.01 Name
    7         N I,IEN,CNT,X,DTXT,CURTM,DEFROUTE
    8         S DEFROUTE=""
    9         S I=0,CNT=44,CURTM=$$NOW^XLFDT
    10         F  Q:I'<CNT  S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM=""  D
    11         . S IEN="" F  S IEN=$O(^ORD(101.43,XREF,FROM,IEN),DIR) Q:'IEN  D
    12         . . S X=^ORD(101.43,XREF,FROM,IEN)
    13         . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
    14         . . Q:$P(X,U,5)  S I=I+1
    15         . . I XREF="S.IVA RX"!(XREF="S.IVB RX") S DEFROUTE=$P($G(^ORD(101.43,IEN,"PS")),U,8)
    16         . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)_U_DEFROUTE
    17         . . E  S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)_U_DEFROUTE
    18         Q
    19 ODITMBC(Y,XREF,ODLST)   ;
    20         N CNT,NM,XRF
    21         S CNT=0,NM=0,XRF=XREF
    22         F  S CNT=$O(ODLST(CNT)) Q:'CNT  D FNDINFO(.Y,ODLST(CNT))
    23         Q
    24 FNDINFO(Y,ODIEN)        ;
    25         D FNDINFO^ORWDX1(.Y,.ODIEN)
    26         Q
    27 DLGDEF(LST,DLG) ; Format mapping for a dlg
    28         D DLGDEF^ORWDX1(.LST,.DLG)
    29         Q
    30 DLGQUIK(LST,QO) ;(NOT USED)
    31         D LOADRSP(.LST,QO)
    32         Q
    33 LOADRSP(LST,RSPID,TRANS)             ; Load responses from 101.41 or 100
    34         ; RSPID:  C123456;1-3243 = cached copy,   134-3234 = cached quick
    35         ;         X123456;1      = change order,  134      = quick dialog
    36         N I,J,DLG,INST,ID,VAL,ILST,ROOT,ORLOC S ROOT=""
    37         I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT^ORWDX2
    38         I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)"  G XROOT^ORWDX2
    39         I +RSPID=RSPID  S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT^ORWDX2
    40         Q:ROOT=""
    41         G XROOT^ORWDX2
    42 SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ;
    43         ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog,
    44         ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment
    45         N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS
    46         N XCNT,XCOMM,XDONE,XX  ;SBR
    47         S (XCOMM,XCNT)=""  ;SBR
    48         I $G(ORIFN)'="" D  ;SBR problem only occurs on change or renew orders
    49         . S XCNT=$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT))  ;SBR
    50         . I XCNT'="" S XCOMM=$P($G(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2)  ;SBR
    51         . I XCOMM'="" S XDONE=0,XX="" F  S XX=$O(ORDIALOG("WP",XCOMM,1,XX)) Q:XX=""  D  ;SBR
    52         . . I ORDIALOG("WP",XCOMM,1,XX,0)'="" S XDONE=1 Q  ;SBR
    53         . I XCOMM'="",'$G(XDONE),$D(ORDIALOG("WP",XCOMM)) K ORDIALOG("WP",XCOMM)  ;SBR
    54         S ORCATFN="" I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1)
    55         ;Remove treating facility if inpatient and IMO order 26.42
    56         I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS")
    57         I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS")
    58         I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG")
    59         I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT")
    60         ;=====================================================
    61         ; Changed for v26.27 (RV)
    62         S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O")
    63         ;I $L($G(OREVENT)) D
    64         ;. S ONPASS=0
    65         ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT)
    66         ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T")
    67         ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
    68         ;E  S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
    69         ;=====================================================
    70         I DLG="PS MEDS" S ORWP94=1 D
    71         . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY"
    72         . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR"
    73         . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE"
    74         I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D
    75         . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE")
    76         I DLG="PSJ OR PAT OE" S ORCAT="I"
    77         S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O"
    78         S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
    79         I ORDG=$O(^ORD(100.98,"B","LAB",0)) D  ;use section
    80         . N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
    81         . S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB)
    82         K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero
    83         M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK")
    84         S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0))
    85         I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0))
    86         I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD")
    87         I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL")
    88         D GETDLG1^ORCD(ORDIALOG)
    89         I $L(ORCATFN) S ORCAT=ORCATFN
    90         I $G(ORWP94) D
    91         . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0))
    92         . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
    93         . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@"
    94         . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0))
    95         . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0))
    96         S ORSRC=$G(ORSRC)
    97         D DELPI^ORWDX1 ;delete empty PI
    98         I $G(ORIFN)="" D  ; new order
    99         . D EN^ORCSAVE
    100         . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
    101         . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG
    102         E  D
    103         . N OR0
    104         . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11)
    105         . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13)
    106         . D XX^ORCSAVE ; edit order
    107         . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
    108         Q
    109 SENDED(ORWLST,ORIENS,TS,LOC)    ; Release EDOs to svc
    110         N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK
    111         S ORWERR="",ORIX=0,LOC=LOC_";SC("
    112         F  S ORIX=$O(ORIENS(ORIX)) Q:'ORIX  D
    113         . S ORIFN=ORIENS(ORIX)
    114         . S PTEVT=$P(^OR(100,+ORIFN,0),U,17) I PTEVT S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)="" I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" ;195
    115         . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1
    116         . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
    117         . I $D(^OR(100,+ORIFN,8,ORDA,0)) D
    118         .. S ORSIGST=$P($G(^(0)),U,4)
    119         .. S ORNATURE=$P($G(^(0)),U,12)
    120         . S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location
    121         . S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty
    122         . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2)
    123         . I OK,$G(LOCK) D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195
    124         . S ORWLST(ORIX)=ORIENS(ORIX)
    125         . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q
    126         . E  D
    127         .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17)
    128         .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2)
    129         . S X="RS"
    130         . S $P(ORWLST(ORIX),U,2)=X
    131         S J=0 F  S J=$O(EVENT(J)) Q:'+J  D UNLEVT^ORX2(J) ;195
    132         Q
    133 SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC)     ; Sign
    134         ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code
    135         ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order
    136 SEND1   N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I
    137         S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0
    138         F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1
    139         S ORWI=0 F  S ORWI=$O(ORWREC(ORWI)) Q:'ORWI  D
    140         . S X=ORWREC(ORWI),ORWERR=""
    141         . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4)
    142         . S ORBEF=0
    143         . I '$D(^OR(100,+ORDERID,0)) Q
    144         . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15)
    145         . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR)
    146         . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR)
    147         . I $L(ORWERR) S ORWERR="1^"_ORWERR
    148         . I '$L(ORWERR) D
    149         .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D  ; lab batch start
    150         ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1
    151         .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2)
    152         .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID)
    153         . S ORWLST(ORWI)=ORDERID,X=""
    154         . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q
    155         . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R"
    156         . I ORWSIG'=2 S X=X_"S"
    157         . S $P(ORWLST(ORWI),U,2)=X
    158         I $G(ORLAB) D BTS^ORMBLD(ORVP)
    159         Q
    160 DLGID(VAL,ORIFN)        ; return dlg IEN for order
    161         S VAL=$P(^OR(100,+ORIFN,0),U,5)
    162         S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0)
    163         Q
    164 FORMID(VAL,ORIFN)        ; Base dlg FormID for an order
    165         N DLG
    166         S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5)
    167         Q:$P(DLG,";",2)'="ORD(101.41,"
    168         D FORMID^ORWDXM(.VAL,+DLG)
    169         Q
    170 AGAIN(VAL,DLG)   ; return true to keep dlg for another order
    171         S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9)
    172         Q
    173 DGRP(VAL,DLG)     ; Display grp pointer for a dlg
    174         S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm
    175         S VAL=$P($G(^ORD(101.41,DLG,0)),U,5)
    176         Q
    177 DGNM(VAL,NM)    ; Display grp pointer for name
    178         S VAL=$O(^ORD(100.98,"B",NM,0))
    179         Q
    180 WRLST(LST,LOC)  ; List of dlgs for writing orders
    181         G WRLST1^ORWDX1
    182 MSG(LST,IEN)    ; Msg text for orderable item
    183         N I
    184         S I=0 F  S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0  S LST(I)=^(I,0)
    185         Q
    186 DISMSG(VAL,IEN) ; Disabled mge for ordering dlg
    187         S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3)
    188         Q
    189 LOCK(OK,DFN)    ; Attempt to lock pt for ordering
    190         S OK=$$LOCK^ORX2(DFN)
    191         Q
    192 UNLOCK(OK,DFN)  ; Unlock pt for ordering
    193         D UNLOCK^ORX2(DFN) S OK=1
    194         Q
    195 LOCKORD(OK,ORIFN)       ; Attempt to lock order
    196         S OK=$$LOCK1^ORX2(ORIFN)
    197         Q
    198 UNLKORD(OK,ORIFN)       ; Unlock order
    199         D UNLK1^ORX2(ORIFN) S OK=1
    200         Q
     1ORWDX ; SLC/KCM/REV/JLI - Order dailog utilities ;4/21/07  19:18
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,269**;Dec 17, 1997;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11NXT() ; -- Gets index in array
     12 S ILST=ILST+1
     13 Q ILST
     14 ;
     15ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items
     16 ; Y(n)=IEN^.01 Name^.01 Name  -or-  IEN^Synonym <.01 Name>^.01 Name
     17 N I,IEN,CNT,X,DTXT,CURTM
     18 S I=0,CNT=44,CURTM=$$NOW^XLFDT
     19 F  Q:I'<CNT  S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM=""  D
     20 . S IEN="" F  S IEN=$O(^ORD(101.43,XREF,FROM,IEN),DIR) Q:'IEN  D
     21 . . S X=^ORD(101.43,XREF,FROM,IEN)
     22 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
     23 . . Q:$P(X,U,5)  S I=I+1
     24 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
     25 . . E  S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
     26 Q
     27ODITMBC(Y,XREF,ODLST) ;
     28 N CNT,NM,XRF
     29 S CNT=0,NM=0,XRF=XREF
     30 F  S CNT=$O(ODLST(CNT)) Q:'CNT  D FNDINFO(.Y,ODLST(CNT))
     31 Q
     32FNDINFO(Y,ODIEN) ;
     33 D FNDINFO^ORWDX1(.Y,.ODIEN)
     34 Q
     35DLGDEF(LST,DLG) ; Format mapping for a dlg
     36 D DLGDEF^ORWDX1(.LST,.DLG)
     37 Q
     38DLGQUIK(LST,QO) ;(NOT USED)
     39 D LOADRSP(.LST,QO)
     40 Q
     41LOADRSP(LST,RSPID)      ; Load responses from 101.41 or 100
     42 ; RSPID:  C123456;1-3243 = cached copy,   134-3234 = cached quick
     43 ;         X123456;1      = change order,  134      = quick dialog
     44 N I,J,DLG,INST,ID,VAL,ILST,ROOT S ROOT=""
     45 I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT
     46 I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)"  G XROOT
     47 I +RSPID=RSPID  S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT
     48 Q:ROOT=""
     49XROOT S (ILST,I)=0 F  S I=$O(@ROOT@(I)) Q:I'>0  D
     50 . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
     51 . S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
     52 . I '$L(ID) S ID="ID"_DLG
     53 . S VAL=$G(@ROOT@(I,1))
     54 . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
     55 . I $E(RSPID)="C",(ID="START"),VAL Q  ; skip literal start time on copy
     56 . S LST($$NXT)="~"_DLG_U_INST_U_ID
     57 . I $L(VAL) D
     58 .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
     59 . I $D(@ROOT@(I,2))>1 D
     60 .. S J=0 F  S J=$O(@ROOT@(I,2,J)) Q:J'>0  D
     61 ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
     62 I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J)
     63 Q
     64SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ;
     65 ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog,
     66 ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment
     67 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS
     68 ; JD FIX FOR WASHINGTON DC
     69 ;I '$L(ORSRC)!($G(ORSRC)=" ")!($G(ORSRC)=0) S ORSRC=$P(ORVP,U,2)
     70 ;S ORVP=$P(ORVP,U)
     71 ; END FIX JD
     72 S ORCATFN=""
     73 I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1)
     74 ;Remove treating facility if inpatient and IMO order 26.42
     75 I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS")
     76 I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS")
     77 I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG")
     78 I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT")
     79 ;=======
     80 ; Changed for v26.27 (RV)
     81 S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O")
     82 ;I $L($G(OREVENT)) D
     83 ;. S ONPASS=0
     84 ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT)
     85 ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T")
     86 ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
     87 ;E  S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
     88 ;=======
     89 I DLG="PS MEDS" S ORWP94=1 D
     90 . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY"
     91 . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR"
     92 . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE"
     93 I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D
     94 . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE")
     95 I DLG="PSJ OR PAT OE" S ORCAT="I"
     96 S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O"
     97 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
     98 K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero
     99 M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK")
     100 S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0))
     101 I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0))
     102 I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD")
     103 I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL")
     104 D GETDLG1^ORCD(ORDIALOG)
     105 I $L(ORCATFN) S ORCAT=ORCATFN
     106 I $G(ORWP94) D
     107 . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0))
     108 . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
     109 . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@"
     110 . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0))
     111 . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0))
     112 S ORSRC=$G(ORSRC)
     113 D DELPI^ORWDX1 ;delete empty PI
     114 I $G(ORIFN)="" D  ; new order
     115 . D EN^ORCSAVE
     116 . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
     117 . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG
     118 E  D
     119 . N OR0
     120 . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11)
     121 . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13)
     122 . D XX^ORCSAVE ; edit order
     123 . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
     124 Q
     125SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc
     126 N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK
     127 S ORWERR="",ORIX=0,LOC=LOC_";SC("
     128 F  S ORIX=$O(ORIENS(ORIX)) Q:'ORIX  D
     129 . S ORIFN=ORIENS(ORIX)
     130 . S PTEVT=$P(^OR(100,+ORIFN,0),U,17) I PTEVT S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)="" I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" ;195
     131 . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1
     132 . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
     133 . I $D(^OR(100,+ORIFN,8,ORDA,0)) D
     134 .. S ORSIGST=$P($G(^(0)),U,4)
     135 .. S ORNATURE=$P($G(^(0)),U,12)
     136 . S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location
     137 . S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty
     138 . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2)
     139 . I OK,$G(LOCK) D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195
     140 . S ORWLST(ORIX)=ORIENS(ORIX)
     141 . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q
     142 . E  D
     143 .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17)
     144 .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2)
     145 . S X="RS"
     146 . S $P(ORWLST(ORIX),U,2)=X
     147 S J=0 F  S J=$O(EVENT(J)) Q:'+J  D UNLEVT^ORX2(J) ;195
     148 Q
     149SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign
     150 ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code
     151 ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order
     152SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I
     153 S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0
     154 F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1
     155 S ORWI=0 F  S ORWI=$O(ORWREC(ORWI)) Q:'ORWI  D
     156 . S X=ORWREC(ORWI),ORWERR=""
     157 . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4)
     158 . S ORBEF=0
     159 . I '$D(^OR(100,+ORDERID,0)) Q
     160 . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15)
     161 . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR)
     162 . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR)
     163 . I $L(ORWERR) S ORWERR="1^"_ORWERR
     164 . I '$L(ORWERR) D
     165 .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D  ; lab batch start
     166 ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1
     167 .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2)
     168 .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID)
     169 .. S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX
     170 .. Q:PSOSITE=""  ;Quits with no autofinish if File#44 does not point to File#59
     171 .. I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)="Y",$$GET1^DIQ(100,+ORDERID_",",12)="OUTPATIENT PHARMACY" D EN^PSOAFIN ;vfam
     172 . S ORWLST(ORWI)=ORDERID,X=""
     173 . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q
     174 . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R"
     175 . I ORWSIG'=2 S X=X_"S"
     176 . S $P(ORWLST(ORWI),U,2)=X
     177 I $G(ORLAB) D BTS^ORMBLD(ORVP)
     178 Q
     179EXTVAL(IVAL,DLG) ; External value given a dlg ptr
     180 N ORDIALOG
     181 S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2)
     182 S ORDIALOG(DLG,1)=IVAL
     183 I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL  ; free text date/time
     184 Q $$EXT^ORCD(DLG,1)  ; all others
     185DLGID(VAL,ORIFN) ; return dlg IEN for order
     186 S VAL=$P(^OR(100,+ORIFN,0),U,5)
     187 S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0)
     188 Q
     189FORMID(VAL,ORIFN)  ; Base dlg FormID for an order
     190 N DLG
     191 S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5)
     192 Q:$P(DLG,";",2)'="ORD(101.41,"
     193 D FORMID^ORWDXM(.VAL,+DLG)
     194 Q
     195AGAIN(VAL,DLG)  ; return true to keep dlg for another order
     196 S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9)
     197 Q
     198DGRP(VAL,DLG)   ; Display grp pointer for a dlg
     199 S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm
     200 S VAL=$P($G(^ORD(101.41,DLG,0)),U,5)
     201 Q
     202DGNM(VAL,NM) ; Display grp pointer for name
     203 S VAL=$O(^ORD(100.98,"B",NM,0))
     204 Q
     205WRLST(LST,LOC) ; List of dlgs for writing orders
     206 G WRLST1^ORWDX1
     207MSG(LST,IEN) ; Msg text for orderable item
     208 N I
     209 S I=0 F  S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0  S LST(I)=^(I,0)
     210 Q
     211DISMSG(VAL,IEN) ; Disabled mge for ordering dlg
     212 S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3)
     213 Q
     214LOCK(OK,DFN) ; Attempt to lock pt for ordering
     215 S OK=$$LOCK^ORX2(DFN)
     216 Q
     217UNLOCK(OK,DFN) ; Unlock pt for ordering
     218 D UNLOCK^ORX2(DFN) S OK=1
     219 Q
     220LOCKORD(OK,ORIFN) ; Attempt to lock order
     221 S OK=$$LOCK1^ORX2(ORIFN)
     222 Q
     223UNLKORD(OK,ORIFN) ; Unlock order
     224 D UNLK1^ORX2(ORIFN) S OK=1
     225 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX1.m

    r613 r623  
    1 ORWDX1  ; SLC/KCM/REV - Utilities for Order Dialogs ;06/06/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 WRLST(LST,LOC)  ; Return list of dialogs for writing orders
    5         ; .Y(n): DlgName^ListBox Text
    6 WRLST1  N ANENT
    7         S LOC=+$G(LOC)_";SC(" I 'LOC S LOC=""
    8         S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
    9         D WRLSTB(.LST) Q:$D(LST)>1  ; check ORWDX WRITE ORDERS first
    10         N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP
    11         D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR
    12         S I=0 F  S I=$O(ORX(I)) Q:'I  D
    13         . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5))
    14         . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4)
    15         . S:'$L(TXT) TXT=$P(X0,U,2)
    16         . I $P(X0,U,4)="M" S:'FID FID=1001
    17         . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT
    18         Q
    19 WRLSTB(LST)         ; return menu from which Write Orders list is built
    20         N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP
    21         S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU
    22         S SEQ=0 F  S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ  D
    23         . S IEN=0 F  S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN  D
    24         . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4)
    25         . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5)
    26         . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5)
    27         . . S:'$L(TXT) TXT=$P(X,U,2)
    28         . . I TYP="M" S:'FID FID=1001
    29         . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT
    30         Q
    31 DELPI   ; delete PI from ORDIALOG if PI = ""
    32         ;Called from SAVE^ORWDX
    33         N ORPI S ORPI=0
    34         S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI))
    35         Q:'$D(ORDIALOG(ORPI))
    36         I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q
    37         N PINODE,PITX
    38         S PITX="",PINODE=$G(ORDIALOG(ORPI,1))
    39         S PITX=$G(@PINODE@(1,0))
    40         S PITX=$TR(PITX," ","")
    41         I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q
    42         N ORSIG S ORSIG=+$O(^ORD(101.41,"B","OR GTX SIG",0))
    43         I $$STR^ORWDXR(ORSIG)[$$STR^ORWDXR(ORPI) S ORDIALOG(ORPI,"FORMAT")="@"
    44         Q
    45 FNDINFO(Y,ODIEN)        ;
    46         N ODI,CRTM,FRM,XX
    47         S FRM="",CRTM=$$NOW^XLFDT
    48         F  S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM=""  D
    49         . S ODI=0 F  S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI  D
    50         .. S XX=^ORD(101.43,XRF,FRM,ODI)
    51         .. I +$P(XX,U,3),$P(XX,U,3)<CRTM Q
    52         .. I ODI=ODIEN D
    53         ... S NM=NM+1
    54         ... I 'XX S Y(NM)=ODIEN_U_$P(XX,U,2)_U_$P(XX,U,2)
    55         ... E  S Y(NM)=ODIEN_U_$P(XX,U,2)_$C(9)_"<"_$P(XX,U,4)_">"_U_$P(XX,U,4)
    56         Q
    57 DLGDEF(LST,DLG) ; Format mapping for a dlg
    58         N I,IEN,ILST,X0,X2,XW  S ILST=0
    59         I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0))
    60         E  S DLG=$O(^ORD(101.41,"B",DLG,0))
    61         Q:'DLG
    62         S I=0 F  S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0  D
    63         . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2)
    64         . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7)
    65         . I $P(X0,U,11) S $P(LST(ILST),U,11)=1
    66         . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3)
    67         . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE"
    68         . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS"
    69         . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN
    70         . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D
    71         .. N SEQ,DA,CHILD S CHILD=""
    72         .. S SEQ=0 F  S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ  D
    73         ... S DA=0 F  S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA  D
    74         .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~"
    75         .. S $P(LST(ILST),U,10)=CHILD
    76         Q
    77         ;
    78 CHANGE(ORLST,ORCLST,DFN,ISIMO)  ;
    79         N CATCH,CHANGE,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG
    80         N CIEN,DIAL,TDIAL,TDIEN,UDIEN,QORDDG,PACKIEN
    81         S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0
    82         S (TDIAL,TDIEN)=0
    83         S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0
    84         S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0
    85         S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDER","")) Q:TDIAL'>0
    86         S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0
    87         S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0
    88         S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0
    89         S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0
    90         S CIEN=$O(^ORD(100.98,"B","CLINIC ORDERS","")) Q:CIEN'>0
    91         S CNT=0 F  S CNT=$O(ORCLST(CNT)) Q:CNT'>0  D
    92         .S CHANGE=0
    93         .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";")
    94         .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11)
    95         .S ORLOC=$P($G(ORCLST(CNT)),U,2)
    96         .S OR3=$G(^OR(100,ORIEN,3))
    97         .S DIAL=$P(OR3,U,4)
    98         .;Remove Treating Speciality if the order location is the clinic
    99         .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC("),$P($G(^SC(ORLOC,0)),U,3)="C" D  Q
    100         ..S $P(^OR(100,ORIEN,0),U,13)=""
    101         .;
    102         .;CHANGE PATIENT LOCATION AND PATIENT STATUS.
    103         .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC("
    104         .S PACKIEN=$P(^OR(100,ORIEN,0),U,14)
    105         .I $$GET1^DIQ(9.4,PACKIEN_",",1)'="PSO" S $P(^OR(100,ORIEN,0),U,12)="I"
    106         .;
    107         .;Check for IMO orders Nursing Dialog problem
    108         .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11)
    109         .;
    110         .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):INPDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH)
    111         .;
    112         .;Check for Quick Order Dialog
    113         .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11),ISIMO=1 D
    114         ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5)
    115         ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=INPDIEN,DIAL=(INP_";ORD(101.41,") Q
    116         ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q
    117         ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q
    118         .;
    119         .;Add treating spec if Inpatient order
    120         .;I (ISIMO=1)&(DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D
    121         .;.S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103))
    122         .I ISIMO=0 S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103))
    123         Q
    124         ;
    125 STCHANGE(ORY,DFN,ORYARR)        ;
    126         N CNT,DONE,NODE,PHARMID,STR,STATUS
    127         S ORY=0,DONE=0
    128         I '$$PATCH^XPDUTL("PSS*1.0*93") Q
    129         S CNT=0 F  S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0)  D
    130         . S NODE=$G(ORYARR(CNT))
    131         . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2)
    132         . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1
    133         Q
    134 ORDMATCH(ORY,DFN,ORYARR)        ;
    135         N ACTION,CNT,IEN,MATCH,ORDERID,STATUS
    136         S CNT=0,MATCH=1
    137         F  S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(MATCH=0)  D
    138         . S ORDERID=$P(ORYARR(CNT),U),STATUS=$P(ORYARR(CNT),U,2)
    139         . I ORDERID=0,$G(ACTION)="" Q
    140         . S IEN=$P(ORDERID,";"),ACTION=$P(ORDERID,";",2)
    141         . I STATUS=$P($G(^OR(100,IEN,3)),U,3) Q
    142         . I $P($G(^ORD(100.01,STATUS,0)),U)="DISCONTINUED/EDIT" Q
    143         . ;S MATCH=0
    144         . I $P($G(^OR(100,IEN,8,ACTION,0)),U,15)'=STATUS S MATCH=0
    145         S ORY=MATCH
    146         Q
    147         ;
    148 DCREN(ORY,ORYARR)       ;
    149         N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS
    150         S CNT1=0
    151         S CNT=0 F  S CNT=$O(ORYARR(CNT)) Q:CNT'>0  D
    152         .S ORGID=ORYARR(CNT)
    153         .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT=""
    154         .S OR3=$G(^OR(100,ORID,3))
    155         .;Make sure current order status is pending
    156         .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q
    157         .S ORG=$P($G(OR3),U,5) Q:ORG'>0
    158         .;do not add original order if it is expired
    159         .S STATUS=$P(^OR(100,ORG,3),U,3)
    160         .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q
    161         .;Do not add original order if Stop date has pass
    162         .I $P(^OR(100,ORG,0),U,9)'>$$NOW^XLFDT Q
    163         .;make sure current order is a renewed order
    164         .I $P(OR3,U,11)'=2 Q
    165         .S ACT=+$P($G(^OR(100,ORG,3)),U,7)
    166         .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT
    167         Q
    168 DCORIG(ORY,ORIEN)       ;
    169         S $P(^OR(100,+ORIEN,6),U,9)=1
    170         Q
    171 UNDCORIG(ORY,ORYARR)    ;
    172         N CNT
    173         S CNT=0 F  S CNT=$O(ORYARR(CNT)) Q:CNT'>0  S $P(^OR(100,+ORYARR(CNT),6),U,9)=0
    174         Q
    175 PATWARD(ORY,DFN)        ;
    176         S ORY=0
    177         I $G(^DPT(DFN,.1))'="" S ORY=1
    178         Q
    179 ISPEND(ORIFN)   ;Is the order's status pending?
    180         N ISPEND,PENDST,N3 S ISPEND=0
    181         Q:'$D(^OR(100,+ORIFN,3))
    182         S PENDST=$O(^ORD(100.01,"B","PENDING",0))
    183         S N3=$G(^OR(100,+ORIFN,3))
    184         I $P(N3,U,3)=PENDST S ISPEND=1
    185         Q ISPEND
     1ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;10/14/05
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215**;Dec 17, 1997
     3 ;
     4WRLST(LST,LOC) ; Return list of dialogs for writing orders
     5 ; .Y(n): DlgName^ListBox Text
     6WRLST1 N ANENT
     7 S LOC=+$G(LOC)_";SC(" I 'LOC S LOC=""
     8 S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
     9 D WRLSTB(.LST) Q:$D(LST)>1  ; check ORWDX WRITE ORDERS first
     10 N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP
     11 D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR
     12 S I=0 F  S I=$O(ORX(I)) Q:'I  D
     13 . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5))
     14 . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4)
     15 . S:'$L(TXT) TXT=$P(X0,U,2)
     16 . I $P(X0,U,4)="M" S:'FID FID=1001
     17 . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT
     18 Q
     19WRLSTB(LST)     ; return menu from which Write Orders list is built
     20 N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP
     21 S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU
     22 S SEQ=0 F  S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ  D
     23 . S IEN=0 F  S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN  D
     24 . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4)
     25 . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5)
     26 . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5)
     27 . . S:'$L(TXT) TXT=$P(X,U,2)
     28 . . I TYP="M" S:'FID FID=1001
     29 . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT
     30 Q
     31DELPI ; delete PI from ORDIALOG if PI = ""
     32 ;Called from SAVE^ORWDX
     33 N ORPI S ORPI=0
     34 S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI))
     35 Q:'$D(ORDIALOG(ORPI))
     36 I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q
     37 N PINODE,PITX
     38 S PITX="",PINODE=$G(ORDIALOG(ORPI,1))
     39 S PITX=$G(@PINODE@(1,0))
     40 S PITX=$TR(PITX," ","")
     41 I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI)
     42 Q
     43FNDINFO(Y,ODIEN) ;
     44 N ODI,CRTM,FRM,XX
     45 S FRM="",CRTM=$$NOW^XLFDT
     46 F  S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM=""  D
     47 . S ODI=0 F  S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI  D
     48 .. S XX=^ORD(101.43,XRF,FRM,ODI)
     49 .. I +$P(XX,U,3),$P(XX,U,3)<CRTM Q
     50 .. I ODI=ODIEN D
     51 ... S NM=NM+1
     52 ... I 'XX S Y(NM)=ODIEN_U_$P(XX,U,2)_U_$P(XX,U,2)
     53 ... E  S Y(NM)=ODIEN_U_$P(XX,U,2)_$C(9)_"<"_$P(XX,U,4)_">"_U_$P(XX,U,4)
     54 Q
     55DLGDEF(LST,DLG) ; Format mapping for a dlg
     56 N I,IEN,ILST,X0,X2,XW  S ILST=0
     57 I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0))
     58 E  S DLG=$O(^ORD(101.41,"B",DLG,0))
     59 Q:'DLG
     60 S I=0 F  S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0  D
     61 . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2)
     62 . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7)
     63 . I $P(X0,U,11) S $P(LST(ILST),U,11)=1
     64 . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3)
     65 . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE"
     66 . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS"
     67 . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN
     68 . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D
     69 .. N SEQ,DA,CHILD S CHILD=""
     70 .. S SEQ=0 F  S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ  D
     71 ... S DA=0 F  S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA  D
     72 .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~"
     73 .. S $P(LST(ILST),U,10)=CHILD
     74 Q
     75 ;
     76CHANGE(ORLST,ORCLST,DFN) ;
     77 N CATCH,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG
     78 N CIEN,DIAL,TDIAL,TDIEN,UDIEN,QORDDG
     79 S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0
     80 S (TDIAL,TDIEN)=0
     81 S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0
     82 S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0
     83 S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE","")) Q:TDIAL'>0
     84 S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0
     85 S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0
     86 S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0
     87 S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0
     88 S CIEN=$O(^ORD(100.98,"B","CLINIC ORDERS","")) Q:CIEN'>0
     89 S CNT=0 F  S CNT=$O(ORCLST(CNT)) Q:CNT'>0  D
     90 .S CHANGE=0
     91 .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";")
     92 .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11)
     93 .I ORDG'=INPDIEN,ORDG'=IVMDIEN,ORDG'=UDIEN,ORDG'=TIEN,ORDG'=CIEN Q
     94 .S ORLOC=$P($G(ORCLST(CNT)),U,2)
     95 .S OR3=$G(^OR(100,ORIEN,3))
     96 .S DIAL=$P(OR3,U,4)
     97 .
     98 .;
     99 .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC(") D  Q
     100 ..;Remove treating spec. if IMO order 26.42
     101 ..I $P($G(^OR(100,ORIEN,0)),U,11)=CIEN S $P(^OR(100,ORIEN,0),U,13)=""
     102 .;
     103 .;CHANGE PATIENT LOCATION AND PATIENT STATUS.
     104 .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC("
     105 .S $P(^OR(100,ORIEN,0),U,12)="I"
     106 .;
     107 .;Check for IMO orders Nursing Dialog problem
     108 .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11)
     109 .;
     110 .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):INPDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH)
     111 .;
     112 .;Check for Quick Order Dialog
     113 .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11) D
     114 ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5)
     115 ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=INPDIEN,DIAL=(INP_";ORD(101.41,") Q
     116 ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q
     117 ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q
     118 .;
     119 .;Add treating spec if Inpatient order
     120 .I (DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D
     121 ..S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103))
     122 Q
     123 ;
     124STCHANGE(ORY,DFN,ORYARR) ;
     125 N CNT,DONE,NODE,PHARMID,STR,STATUS
     126 S ORY=0,DONE=0
     127 I '$$PATCH^XPDUTL("PSS*1.0*93") Q
     128 S CNT=0 F  S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0)  D
     129 . S NODE=$G(ORYARR(CNT))
     130 . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2)
     131 . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1
     132 Q
     133DCREN(ORY,ORYARR) ;
     134 N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS
     135 S CNT1=0
     136 S CNT=0 F  S CNT=$O(ORYARR(CNT)) Q:CNT'>0  D
     137 .S ORGID=ORYARR(CNT)
     138 .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT=""
     139 .S OR3=$G(^OR(100,ORID,3))
     140 .;Make sure current order status is pending
     141 .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q
     142 .S ORG=$P($G(OR3),U,5) Q:ORG'>0
     143 .;do not add original order if it is expired
     144 .S STATUS=$P(^OR(100,ORG,3),U,3)
     145 .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q
     146 .;make sure current order is a renewed order
     147 .I $P(OR3,U,11)'=2 Q
     148 .S ACT=+$P($G(^OR(100,ORG,3)),U,7)
     149 .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT
     150 Q
     151PATWARD(ORY,DFN) ;
     152 S ORY=0
     153 I $G(^DPT(DFN,.1))'="" S ORY=1
     154 Q
     155ISPEND(ORIFN) ;Is the order's status pending?
     156 N ISPEND,PENDST,N3 S ISPEND=0
     157 Q:'$D(^OR(100,+ORIFN,3))
     158 S PENDST=$O(^ORD(100.01,"B","PENDING",0))
     159 S N3=$G(^OR(100,+ORIFN,3))
     160 I $P(N3,U,3)=PENDST S ISPEND=1
     161 Q ISPEND

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m

    r613 r623  
    1 ORWDXA  ; SLC/KCM/JLI - Utilites for Order Actions; 10/07/2007 ; 2/7/08 11:48am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 VALID(VAL,ORID,ACTION,ORNP,ORWNAT)      ; Return error message if not valid action for order
    5         N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0
    6         I +ORID=0 S VAL="This order has been deleted." Q
    7         I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q
    8         I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE
    9         N ORNSS S ORNSS=1
    10         I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID)
    11         I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q
    12         I (ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q
    13         S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2)  ; ORCACT0 expects defined
    14         I (ACTION="RN") D  Q:$L(VAL)  ; ** There's got to be a better way!
    15         . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41,"
    16         . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q
    17         . D AUTH^ORWDPS32(.VAL,ORNP)
    18         . I VAL S VAL=$P(VAL,U,2)
    19         . E  S VAL=""
    20         S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^")
    21         I ACTION="CR" S ACTION="VR"
    22         I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined???
    23         I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D  Q
    24         . S VAL="You are not authorized to verify these orders."
    25         I $L(VAL) Q
    26         N OIIEN,ISIV,IVOD
    27         S (ISIV,OIIEN,IVOD)=0
    28         I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D  Q:$L(VAL)
    29         . S ISIV=$P(^OR(100,+ORID,0),U,11)
    30         . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1
    31         . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID)
    32         . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q
    33         . N DLG,FRM
    34         . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0
    35         . I $P(DLG,";",2)'="ORD(101.41," S DLG=0
    36         . I DLG D FORMID^ORWDXM(.FRM,+DLG)
    37         . I '(DLG&FRM) D
    38         . . S VAL="Copy & Change are not implemented for this order that predates CPRS."
    39         N OREBUILD  ; sometimes left defined by $$VALID
    40         ;I (ACTION="RW")!(ACTION="XFR")!(ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q
    41         I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error
    42         Q
    43         ;
    44 HOLD(REC,ORID,ORNP)     ; Place an order on hold
    45         N ACTDA
    46         S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP)
    47         D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
    48         Q
    49 UNHOLD(REC,ORID,ORNP)   ; Release an order from hold
    50         N ACTDA
    51         S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
    52         D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
    53         Q
    54 DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD)    ; Discontinue/Cancel/Delete an order
    55         N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
    56         N X3,X8,CURRACT
    57         Q:'+ORID
    58         I $G(DCORIG)="" S DCORIG=0
    59         S CURRACT=0
    60         S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE=""
    61         I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2)
    62         S:NATURE="" NATURE="W"  ; S:ORNP=DUZ NATURE="E"
    63         ;change the way create work to support forcing signature for all DC
    64         ;reasons
    65         S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE)
    66         ;S CREATE=$$CREATE^ORX1(NATURE)
    67         S X3=$G(^OR(100,+ORID,3))
    68         S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1)
    69         I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D
    70         . S X8=$G(^OR(100,+ORID,8,CURRACT,0))
    71         . S SIGSTS=$P(X8,U,4)
    72         . S $P(ORID,";",2)=CURRACT
    73         E  D
    74         . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0)
    75         . S SIGSTS=$P(X8,U,4)
    76         I '$D(SIGSTS) S SIGSTS=1
    77         S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15)
    78         I (STATUS=10)!(STATUS=11) D  Q   ; delete/cancel unreleased order
    79         . N RPLORD
    80         . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5)    ; replaced order
    81         . D GETBYIFN^ORWORR(.REC,ORID)
    82         . I STATUS=10,($P(X8,U,4)'=2) D  ; CANCEL signed, delayed, unreleased
    83         . . ; taken from CLRDLY^ORCACT2
    84         . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG)
    85         . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled",DCORIG)
    86         . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13
    87         . E  D                           ; CANCEL OR DELETE unsigned, unreleased
    88         . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6)
    89         . . ; delete fwd ptr to order about to be deleted
    90         . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)=""
    91         . . ; delete ptr to order in Patient Event file #100.2
    92         . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT)
    93         . . I $G(ISNEWORD) D DELETE^ORCSAVE2(ORID)
    94         . . I '$G(ISNEWORD) D CANCEL^ORCSAVE2(ORID)
    95         . I RPLORD,'(SIGSTS=1) S ORID=RPLORD  ; for Renews & Changes, show replaced order
    96         . I '$D(^OR(100,+ORID)) D
    97         . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245)
    98         . E  D
    99         . . K REC
    100         . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7))
    101         . S $P(REC(1),U,14)=2 ; DCType = deletion
    102         S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP)
    103         D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG)
    104         D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
    105         S $P(REC(1),U,14)=$S(CREATE:1,1:3)  ;DCType - 1=NewOrder, 3=NewStatus
    106         N PKG
    107         S PKG=$P($G(^OR(100,+ORID,0)),U,14)
    108         S PKG=$$NMSP^ORCD(PKG)
    109         I REASON=16&(PKG="PS") D
    110         . N XMB
    111         . S XMB="OR DRUG ORDER CANCELLED"
    112         . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U)
    113         . S XMB(2)=+ORID
    114         . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2)
    115         . S XMB(3)=$P($G(^DPT(XMB(3),0)),U)
    116         . D ^XMB
    117         Q
    118 DCREQIEN(VAL)   ; Return the IEN for Requesting Physician Cancelled reason
    119         S VAL=$O(^ORD(100.03,"S","REQ",0))
    120         Q
    121 COMPLETE(REC,ORID,ESCODE)       ; Complete an order (generic orders)
    122         ;N X S X=+$E($$NOW^XLFDT,1,12)
    123         ;D DATES^ORCSAVE2(+ORID,,X)
    124         ;D STATUS^ORCSAVE2(+ORID,2)
    125         ; validate ESCode
    126         D COMP^ORCSAVE2(ORID)
    127         D GETBYIFN^ORWORR(.REC,ORID)
    128         Q
    129 VERIFY(REC,ORID,ESCODE,ORVER)   ; Verify an order
    130         ; validate ESCode
    131         S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U))
    132         I ORVER'=U D
    133         . N ORIFN,ORES,ORI
    134         . ; to match 56, need to VERIFY any replaced orders:
    135         . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1
    136         . S ORI="" F  S ORI=$O(ORES(ORI)) Q:ORI=""  D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior
    137         D GETBYIFN^ORWORR(.REC,ORID)
    138         Q
    139 ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted
    140         ;if no user passed from GUI, use ordering provider:
    141         I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID)
    142         I $L($G(ORDUZ))<1 S ORDUZ=DUZ
    143         S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ
    144         Q
    145 FLAG(REC,ORIFN,OREASON,ORNP)    ; Flag an order
    146         N ORB,ORVP,DA,ORPS
    147         D BULLETIN
    148         S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
    149         K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON_$S($G(ORNP):"^^^^"_+ORNP,1:"")
    150         D KILL^XM,MSG^ORCFLAG(ORIFN)
    151         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity
    152         I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
    153         S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
    154         D GETBYIFN^ORWORR(.REC,ORIFN)
    155         Q
    156 BULLETIN        ; Send flagged order bulletin (USED BY FLAG)
    157         N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
    158         S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
    159         ;CLA - 3/21/96:
    160         S ORUSR=+$P(OR0,U,4)
    161         S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
    162         S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG"
    163         S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
    164         Q:$G(BULL)'="Y"   ;quit if parameter value is not 'Y'es
    165         ;
    166         S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))=""
    167         S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE
    168         S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7))
    169         D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
    170         S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
    171         S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON
    172         S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
    173         D EN^XMB
    174         Q
    175 UNFLAG(REC,ORIFN,OREASON)       ; Unflag an order
    176         N DA,ORB,ORNP,ORVP,ORPS
    177         S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
    178         S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN)
    179         S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT  ; Last Activity
    180         S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
    181         S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
    182         D GETBYIFN^ORWORR(.REC,ORIFN)
    183         Q
    184 FLAGTXT(LST,ORID)       ; Return flag reason
    185         N FLAG
    186         S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3))
    187         S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
    188         S LST(2)=$P(FLAG,U,5) ; reason
    189         Q
    190 WCGET(LST,ORID) ; Return ward comments
    191         N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
    192         S I=0 F  S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I  S LST(I)=$G(^(I,0))
    193         Q
    194 WCPUT(ERR,ORID,WCLST)   ; Set ward comments for order
    195         N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
    196         D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST")
    197         S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments."
    198         Q
    199 OFCPLX(ORY,ORID,PRTORDER)       ;Check if ORID is an child of the PRTORDER
    200         N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW
    201         Q:'$D(^OR(100,+ORID,0))
    202         S ISNOW=0
    203         D ISNOW^ORWDXR(.ISNOW,+ORID)
    204         Q:ISNOW
    205         N PKG
    206         S PKG=$P($G(^OR(100,+ORID,0)),U,14)
    207         S PKG=$$NMSP^ORCD(PKG)
    208         I PKG'="PS" Q
    209         I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q
    210         S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0
    211         S PRTORDER=+$P(^(3),U,9)
    212         S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7)
    213         S PRTORDER=PRTORDER_";"_ORDA
    214         S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4)
    215         I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER
    216         S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
    217         S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1))
    218         I NOWVAL=1 Q
    219         E  S ORY="COMPLEX-PSI"_U_PRTORDER
    220         Q
    221 ISACTOI(ORY,OI) ;If it's an active orderable item
    222         I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D
    223         . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
    224         Q
     1ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions; 2/10/03 9:13Am [6/7/05 2:09pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215**;Dec 17, 1997
     3 ;
     4VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order
     5 N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0
     6 I +ORID=0 S VAL="This order has been deleted." Q
     7 I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q
     8 I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE
     9 N ORNSS S ORNSS=1
     10 I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID)
     11 I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q
     12 S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2)  ; ORCACT0 expects defined
     13 I (ACTION="RN") D  Q:$L(VAL)  ; ** There's got to be a better way!
     14 . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41,"
     15 . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q
     16 . D AUTH^ORWDPS32(.VAL,ORNP)
     17 . I VAL S VAL=$P(VAL,U,2)
     18 . E  S VAL=""
     19 S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^")
     20 I ACTION="CR" S ACTION="VR"
     21 I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined???
     22 I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D  Q
     23 . S VAL="You are not authorized to verify these orders."
     24 I $L(VAL) Q
     25 N OIIEN,ISIV,IVOD
     26 S (ISIV,OIIEN,IVOD)=0
     27 I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D  Q:$L(VAL)
     28 . S ISIV=$P(^OR(100,+ORID,0),U,11)
     29 . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1
     30 . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID)
     31 . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q
     32 . N DLG,FRM
     33 . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0
     34 . I $P(DLG,";",2)'="ORD(101.41," S DLG=0
     35 . I DLG D FORMID^ORWDXM(.FRM,+DLG)
     36 . I '(DLG&FRM) D
     37 . . S VAL="Copy & Change are not implemented for this order that predates CPRS."
     38 N OREBUILD  ; sometimes left defined by $$VALID
     39 I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error
     40 Q
     41HOLD(REC,ORID,ORNP)  ; Place an order on hold
     42 N ACTDA
     43 S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP)
     44 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
     45 Q
     46UNHOLD(REC,ORID,ORNP)  ; Release an order from hold
     47 N ACTDA
     48 S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
     49 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
     50 Q
     51DC(REC,ORID,ORNP,ORL,REASON)   ; Discontinue/Cancel/Delete an order
     52 N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
     53 N X3,X8,CURRACT
     54 Q:'+ORID
     55 S CURRACT=0
     56 S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE=""
     57 I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2)
     58 S:NATURE="" NATURE="W"  ; S:ORNP=DUZ NATURE="E"
     59 ;change the way create work to support forcing signature for all DC
     60 ;reasons
     61 S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE)
     62 ;S CREATE=$$CREATE^ORX1(NATURE)
     63 S X3=$G(^OR(100,+ORID,3))
     64 S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1)
     65 I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D
     66 . S X8=$G(^OR(100,+ORID,8,CURRACT,0))
     67 . S SIGSTS=$P(X8,U,4)
     68 . S $P(ORID,";",2)=CURRACT
     69 E  D
     70 . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0)
     71 . S SIGSTS=$P(X8,U,4)
     72 I '$D(SIGSTS) S SIGSTS=1
     73 S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15)
     74 I (STATUS=10)!(STATUS=11) D  Q   ; delete/cancel unreleased order
     75 . N RPLORD
     76 . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5)    ; replaced order
     77 . D GETBYIFN^ORWORR(.REC,ORID)
     78 . I STATUS=10,($P(X8,U,4)'=2) D  ; CANCEL signed, delayed, unreleased
     79 . . ; taken from CLRDLY^ORCACT2
     80 . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON)
     81 . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled")
     82 . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13
     83 . E  D                           ; DELETE unsigned, unreleased
     84 . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6)
     85 . . ; delete fwd ptr to order about to be deleted
     86 . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)=""
     87 . . ; delete ptr to order in Patient Event file #100.2
     88 . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT)
     89 . . D DELETE^ORCSAVE2(ORID)
     90 . I RPLORD,'(SIGSTS=1) S ORID=RPLORD  ; for Renews & Changes, show replaced order
     91 . I '$D(^OR(100,+ORID)) D
     92 . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245)
     93 . E  D
     94 . . K REC
     95 . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7))
     96 . S $P(REC(1),U,14)=2 ; DCType = deletion
     97 S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP)
     98 D SET^ORCACT2(+ORID,NATURE,REASON)
     99 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
     100 S $P(REC(1),U,14)=$S(CREATE:1,1:3)  ;DCType - 1=NewOrder, 3=NewStatus
     101 N PKG
     102 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
     103 S PKG=$$NMSP^ORCD(PKG)
     104 I REASON=16&(PKG="PS") D
     105 . N XMB
     106 . S XMB="OR DRUG ORDER CANCELLED"
     107 . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U)
     108 . S XMB(2)=+ORID
     109 . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2)
     110 . S XMB(3)=$P($G(^DPT(XMB(3),0)),U)
     111 . D ^XMB
     112 Q
     113DCREASON(LST)   ; Return a list of DC reasons
     114 N IEN,ILST,X
     115 S ILST=1,LST(ILST)="~DCReason"
     116 S IEN=0 F  S IEN=$O(^ORD(100.03,IEN)) Q:'IEN  S X=^(IEN,0) D
     117 . I $P(X,U,4) Q                              ; inactive
     118 . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q   ; not OR pkg
     119 . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q  ; nature=auto
     120 . S ILST=ILST+1,LST(ILST)="i"_IEN_U_$P(X,U)
     121 S IEN=$O(^ORD(100.03,"C","ORREQ",0))
     122 I IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_$P(^ORD(100.03,IEN,0),U)
     123 Q
     124DCREQIEN(VAL)   ; Return the IEN for Requesting Physician Cancelled reason
     125 S VAL=$O(^ORD(100.03,"S","REQ",0))
     126 Q
     127COMPLETE(REC,ORID,ESCODE)      ; Complete an order (generic orders)
     128 ;N X S X=+$E($$NOW^XLFDT,1,12)
     129 ;D DATES^ORCSAVE2(+ORID,,X)
     130 ;D STATUS^ORCSAVE2(+ORID,2)
     131 ; validate ESCode
     132 D COMP^ORCSAVE2(ORID)
     133 D GETBYIFN^ORWORR(.REC,ORID)
     134 Q
     135VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order
     136 ; validate ESCode
     137 S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U))
     138 I ORVER'=U D
     139 . N ORIFN,ORES,ORI
     140 . ; to match 56, need to VERIFY any replaced orders:
     141 . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1
     142 . S ORI="" F  S ORI=$O(ORES(ORI)) Q:ORI=""  D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior
     143 D GETBYIFN^ORWORR(.REC,ORID)
     144 Q
     145ALERT(DUMMY,ORID,ORDUZ)       ;send alert to user (ORDUZ) when order (ORID) resulted
     146 ;if no user passed from GUI, use ordering provider:
     147 I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID)
     148 I $L($G(ORDUZ))<1 S ORDUZ=DUZ
     149 S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ
     150 Q
     151FLAG(REC,ORIFN,OREASON,ORNP)   ; Flag an order
     152 N ORB,ORVP,DA,ORPS
     153 D BULLETIN
     154 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
     155 K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON
     156 D KILL^XM,MSG^ORCFLAG(ORIFN)
     157 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity
     158 I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
     159 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
     160 D GETBYIFN^ORWORR(.REC,ORIFN)
     161 Q
     162BULLETIN        ; Send flagged order bulletin (USED BY FLAG)
     163 N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
     164 S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
     165 ;CLA - 3/21/96:
     166 S ORUSR=+$P(OR0,U,4)
     167 S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
     168 S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG"
     169 S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
     170 Q:$G(BULL)'="Y"   ;quit if parameter value is not 'Y'es
     171 ;
     172 S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))=""
     173 S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE
     174 S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7))
     175 D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
     176 S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
     177 S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON
     178 S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
     179 D EN^XMB
     180 Q
     181UNFLAG(REC,ORIFN,OREASON)       ; Unflag an order
     182 N DA,ORB,ORNP,ORVP,ORPS
     183 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
     184 S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN)
     185 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT  ; Last Activity
     186 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
     187 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
     188 D GETBYIFN^ORWORR(.REC,ORIFN)
     189 Q
     190FLAGTXT(LST,ORID)      ; Return flag reason
     191 N FLAG
     192 S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3))
     193 S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
     194 S LST(2)=$P(FLAG,U,5) ; reason
     195 Q
     196WCGET(LST,ORID) ; Return ward comments
     197 N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
     198 S I=0 F  S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I  S LST(I)=$G(^(I,0))
     199 Q
     200WCPUT(ERR,ORID,WCLST) ; Set ward comments for order
     201 N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
     202 D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST")
     203 S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments."
     204 Q
     205OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER
     206 N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW
     207 Q:'$D(^OR(100,+ORID,0))
     208 S ISNOW=0
     209 D ISNOW^ORWDXR(.ISNOW,+ORID)
     210 Q:ISNOW
     211 N PKG
     212 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
     213 S PKG=$$NMSP^ORCD(PKG)
     214 I PKG'="PS" Q
     215 I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q
     216 S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0
     217 S PRTORDER=+$P(^(3),U,9)
     218 S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7)
     219 S PRTORDER=PRTORDER_";"_ORDA
     220 S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4)
     221 I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER
     222 S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
     223 S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1))
     224 I NOWVAL=1 Q
     225 E  S ORY="COMPLEX-PSI"_U_PRTORDER
     226 Q
     227ISACTOI(ORY,OI) ;If it's an active orderable item
     228 I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D
     229 . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
     230 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m

    r613 r623  
    1 ORWDXC  ; SLC/KCM - Utilities for Order Checking
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221,243**;Dec 17, 1997;Build 242
    3         ;
    4 ON(VAL) ; returns E if order checking enabled, otherwise D
    5         S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")
    6         Q
    7 FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog
    8         N DGRP
    9         S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP
    10         S DLG=$$DEFDLG^ORWDXQ(DGRP)
    11         S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL)
    12         I VAL="PS" D
    13         . N X
    14         . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ")
    15         . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X)
    16         Q
    17 DISPLAY(LST,DFN,FID)    ; Return list of Order Checks for a FillerID (namespace)
    18         N I,ORX,ORY
    19         S ORX=1,ORX(1)="|"_FID
    20         D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY")
    21         S I=0 F  S I=$O(ORY(I)) Q:I'>0  S LST(I)=$P(ORY(I),U,4)
    22         Q
    23 ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN)     ; Return list of Order Checks on Accept Order
    24         ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
    25         N X,Y,USID,ORCHECK,ORI,ORX,ORY
    26         ; convert relative start date to real start date
    27         S ORL=ORL_";SC(",X=STRT,STRT=""
    28         D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
    29         I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
    30         ; do the SELECT order checks
    31         S ORI=0 F  S ORI=$O(OIL(ORI)) Q:'ORI  D
    32         . S USID=$$USID(OIL(ORI))
    33         . S OIL(ORI,"USID")=USID
    34         . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID
    35         . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT")
    36         . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
    37         . K ORX,ORY
    38         ; do the ACCEPT order checks
    39         S (ORI,ORX)=0 F  S ORI=$O(OIL(ORI)) Q:'ORI  D
    40         . S ORX=ORX+1
    41         . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT
    42         . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
    43         D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT")
    44         I $D(ORY) D RETURN^ORCHECK   ; expects ORY, ORCHECK
    45         ; return ORCHECK as 1 dimensional list
    46         D CHK2LST
    47         Q
    48 DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed
    49         ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
    50         N X,Y,ORCHECK,ORI,ORX,ORY
    51         ; convert relative start date to real start date
    52         S ORL=ORL_";SC(",X=STRT,STRT=""
    53         D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
    54         I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
    55         ; do the ACCEPT order checks
    56         S (ORI,ORX)=0 F  S ORI=$O(OIL(ORI)) Q:'ORI  D
    57         . S ORX=ORX+1
    58         . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT
    59         . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
    60         D EN^ORKCHK(.ORY,DFN,.ORX,"ALL")
    61         I $D(ORY) D RETURN^ORCHECK   ; expects ORY, ORCHECK
    62         ; return ORCHECK as 1 dimensional list
    63         D CHK2LST
    64         Q
    65 SESSION(LST,ORVP,ORLST)  ; Return list of Order Checks on Release Order
    66         N ORES,ORCHECK
    67         S ORVP=+ORVP_";DPT("
    68         S I=0 F  S I=$O(ORLST(I)) Q:'I  D
    69         . I +$P(ORLST(I),";",2)'=1 Q  ; order not new
    70         . I $P(ORLST(I),U,3)="0" Q    ; order not being released
    71         . S ORES($P(ORLST(I),U))=""
    72         D SESSION^ORCHECK
    73         D CHK2LST
    74         Q
    75 SAVECHK(OK,ORVP,RSN,LST)           ; Save order checks for session
    76         N ORCHECK,ORIFN S OK=1
    77         D LST2CHK
    78         I $L(RSN)>0 S ORCHECK("OK")=RSN
    79         S ORIFN=0 F  S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN  D OC^ORCSAVE2
    80         Q
    81 DELORD(OK,ORIFN)             ; Delete order
    82         N STS,DIK,DA
    83         S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0
    84         I (STS=10)!(STS=11) D  Q  ; makes sure it's an unreleased order
    85         . S DA=+ORIFN,DIK="^OR(100," Q:'DA
    86         . D ^DIK
    87         . S OK=1
    88         Q
    89 USID(ORITMX)    ; Return universal svc ID for an orderable item
    90         ; ORITMX = OI^NMSP^PKGINFO
    91         N RSLT,ORDRUG S RSLT=""
    92         I $E($P(ORITMX,U,2),1,2)="PS" D
    93         . I $P(ORITMX,U,2)="PSIV" D
    94         . . N PSOI,TYPE,VOL S VOL=""
    95         . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2)
    96         . . S TYPE=$P($P(ORITMX,U,3),";")
    97         . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2)
    98         . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG)
    99         . . S ORDRUG=+ORDRUG
    100         . E  S ORDRUG=+$P(ORITMX,U,3)
    101         . S RSLT=$$ENDCM^PSJORUTL(ORDRUG)
    102         . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$$NAME50^ORPEAPI(ORDRUG)_"^99PSD"
    103         E  S RSLT=$$USID^ORMBLD(+ORITMX)
    104         I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?)
    105         Q RSLT
    106         ;
    107 CHK2LST ; creates list that can be passed to broker from ORCHECK array
    108         ; expects ORCHECK to be present and populates LST
    109         N ORIFN,ORID,CDL,I,ILST S ILST=1  ;Start array at 1 always leaving room for RDI msg at top
    110         S ORIFN="" F  S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN=""  D
    111         . S CDL=0 F  S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL  D
    112         . . S I=0 F  S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I  D
    113         . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1"
    114         . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q  ; CDL="" means don't show
    115         . . . I $P(ORCHECK(ORIFN,CDL,I),U,1)=99 S LST(1)=ORID_U_ORCHECK(ORIFN,CDL,I) Q  ;Put RDI warning at the top
    116         . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I)
    117         Q
    118 LST2CHK ; create ORCHECK array from list passed by broker
    119         N ORIFN,CDL,I,ILST S I=0
    120         S ILST=0 F  S ILST=$O(LST(ILST)) Q:'ILST  D
    121         . S X=LST(ILST)
    122         . S ORIFN=$P(X,U),CDL=$P(X,U,3)
    123         . I +$G(ORIFN)>0,+$G(CDL)>0 D  ;cla 12/16/03
    124         . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4)
    125         Q
     1ORWDXC ; SLC/KCM - Utilities for Order Checking
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221**;Dec 17, 1997
     3 ;
     4ON(VAL) ; returns E if order checking enabled, otherwise D
     5 S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")
     6 Q
     7FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog
     8 N DGRP
     9 S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP
     10 S DLG=$$DEFDLG^ORWDXQ(DGRP)
     11 S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL)
     12 I VAL="PS" D
     13 . N X
     14 . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ")
     15 . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X)
     16 Q
     17DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace)
     18 N I,ORX,ORY
     19 S ORX=1,ORX(1)="|"_FID
     20 D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY")
     21 S I=0 F  S I=$O(ORY(I)) Q:I'>0  S LST(I)=$P(ORY(I),U,4)
     22 Q
     23ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN)    ; Return list of Order Checks on Accept Order
     24 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
     25 N X,Y,USID,ORCHECK,ORI,ORX,ORY
     26 ; convert relative start date to real start date
     27 S ORL=ORL_";SC(",X=STRT,STRT=""
     28 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
     29 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
     30 ; do the SELECT order checks
     31 S ORI=0 F  S ORI=$O(OIL(ORI)) Q:'ORI  D
     32 . S USID=$$USID(OIL(ORI))
     33 . S OIL(ORI,"USID")=USID
     34 . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID
     35 . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT")
     36 . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
     37 . K ORX,ORY
     38 ; do the ACCEPT order checks
     39 S (ORI,ORX)=0 F  S ORI=$O(OIL(ORI)) Q:'ORI  D
     40 . S ORX=ORX+1
     41 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT
     42 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
     43 D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT")
     44 I $D(ORY) D RETURN^ORCHECK   ; expects ORY, ORCHECK
     45 ; return ORCHECK as 1 dimensional list
     46 D CHK2LST
     47 Q
     48DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed
     49 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
     50 N X,Y,ORCHECK,ORI,ORX,ORY
     51 ; convert relative start date to real start date
     52 S ORL=ORL_";SC(",X=STRT,STRT=""
     53 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
     54 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
     55 ; do the ACCEPT order checks
     56 S (ORI,ORX)=0 F  S ORI=$O(OIL(ORI)) Q:'ORI  D
     57 . S ORX=ORX+1
     58 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT
     59 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
     60 D EN^ORKCHK(.ORY,DFN,.ORX,"ALL")
     61 I $D(ORY) D RETURN^ORCHECK   ; expects ORY, ORCHECK
     62 ; return ORCHECK as 1 dimensional list
     63 D CHK2LST
     64 Q
     65SESSION(LST,ORVP,ORLST)  ; Return list of Order Checks on Release Order
     66 N ORES,ORCHECK
     67 S ORVP=+ORVP_";DPT("
     68 S I=0 F  S I=$O(ORLST(I)) Q:'I  D
     69 . I +$P(ORLST(I),";",2)'=1 Q  ; order not new
     70 . I $P(ORLST(I),U,3)="0" Q    ; order not being released
     71 . S ORES($P(ORLST(I),U))=""
     72 D SESSION^ORCHECK
     73 D CHK2LST
     74 Q
     75SAVECHK(OK,ORVP,RSN,LST)    ; Save order checks for session
     76 N ORCHECK,ORIFN S OK=1
     77 D LST2CHK
     78 I $L(RSN)>0 S ORCHECK("OK")=RSN
     79 S ORIFN=0 F  S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN  D OC^ORCSAVE2
     80 Q
     81DELORD(OK,ORIFN)      ; Delete order
     82 N STS,DIK,DA
     83 S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0
     84 I (STS=10)!(STS=11) D  Q  ; makes sure it's an unreleased order
     85 . S DA=+ORIFN,DIK="^OR(100," Q:'DA
     86 . D ^DIK
     87 . S OK=1
     88 Q
     89USID(ORITMX) ; Return universal svc ID for an orderable item
     90 ; ORITMX = OI^NMSP^PKGINFO
     91 N RSLT,ORDRUG S RSLT=""
     92 I $E($P(ORITMX,U,2),1,2)="PS" D
     93 . I $P(ORITMX,U,2)="PSIV" D
     94 . . N PSOI,TYPE,VOL S VOL=""
     95 . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2)
     96 . . S TYPE=$P($P(ORITMX,U,3),";")
     97 . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2)
     98 . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG)
     99 . . S ORDRUG=+ORDRUG
     100 . E  S ORDRUG=+$P(ORITMX,U,3)
     101 . S RSLT=$$ENDCM^PSJORUTL(ORDRUG)
     102 . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$P($G(^PSDRUG(ORDRUG,0)),U)_"^99PSD"
     103 E  S RSLT=$$USID^ORMBLD(+ORITMX)
     104 I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?)
     105 Q RSLT
     106 ;
     107CHK2LST ; creates list that can be passed to broker from ORCHECK array
     108 ; expects ORCHECK to be present and populates LST
     109 N ORIFN,ORID,CDL,I,ILST S ILST=0
     110 S ORIFN="" F  S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN=""  D
     111 . S CDL=0 F  S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL  D
     112 . . S I=0 F  S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I  D
     113 . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1"
     114 . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q  ; CDL="" means don't show
     115 . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I)
     116 Q
     117LST2CHK ; create ORCHECK array from list passed by broker
     118 N ORIFN,CDL,I,ILST S I=0
     119 S ILST=0 F  S ILST=$O(LST(ILST)) Q:'ILST  D
     120 . S X=LST(ILST)
     121 . S ORIFN=$P(X,U),CDL=$P(X,U,3)
     122 . I +$G(ORIFN)>0,+$G(CDL)>0 D  ;cla 12/16/03
     123 . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4)
     124 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM1.m

    r613 r623  
    1 ORWDXM1 ; SLC/KCM - Order Dialogs, Menus;2/19/03 ;5/27/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215,243**;Dec 17, 1997;Build 242
    3 BLDQRSP(LST,ORIT,FLDS,ISIMO,ENCLOC)     ; Build responses for an order
    4         ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp
    5         ; LST(n)=verify text or reject text
    6         ; ORIT= ptr to 101.41 for quick order, 100 for copy
    7         ;       1   2    3    4   5   6    7    8        11-20
    8         ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables...
    9         ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change
    10         ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?)
    11         K ^TMP("ORWDXMQ",$J)
    12         N ORWMODE ; 0:Dialog,Quick 1:copy order 2:change order
    13         N TEMPCAT ; patient category from DPT file
    14         N ISXFER ; Transfer order?
    15         N ORIMO ;If IMO(inpatient medication on outpatient)
    16         N TEMPORIT
    17         N ADMLOC,PATLOC,ORDLOC,LEVEL,DELAY,SCHLOC,SCHTYP
    18         S PATLOC=$P(FLDS,U,2)
    19         S ORDLOC=$S(ORIT["C":+$P($G(^OR(100,+$P(ORIT,"C",2),0)),U,10),1:0)
    20         S ORIMO=$G(ISIMO)
    21         S ORWMODE=0,ISXFER=""
    22         S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy for now
    23         S:$E(ORIT)="X" ORWMODE=2
    24         S TEMPORIT=ORIT
    25         I ORWMODE S ORIT=$E(ORIT,2,999)
    26         S LST(0)=""
    27         D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8  ;disable
    28         D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8  ;action
    29         I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8  ;no copy
    30         I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q  ;change
    31         I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q
    32         ;radilogy vars
    33         N ORIMTYPE
    34         ;blood bank vars
    35         N ORCOMP,ORTAS
    36         ;lab vars
    37         N LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH
    38         N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH
    39         ;pharmacy vars
    40         N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS
    41         N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94
    42         ;dietetics vars
    43         N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE
    44         ;consults vars
    45         N GMRCNOPD,GMRCNOAT,GMRCREAF
    46         ; setup general env
    47         N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR
    48         N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK
    49         N OREVNTYP
    50         S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
    51         S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8)
    52         S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL
    53         S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1
    54         I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42)
    55         I $L($P(FLDS,U,7))  D
    56         . S OREVENT=$P(FLDS,U,7)
    57         . S OREVNTYP=$P(OREVENT,";",2)
    58         . S OREVENT("TS")=$P(OREVENT,";",3)
    59         . S OREVENT("EFFECTIVE")=$P(OREVENT,";",4)
    60         . S OREVENT=+$P(OREVENT,";",1)
    61         I 'ORWMODE D
    62         . D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path
    63         . S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action
    64         . D SETKEYV^ORWDXM3(KEYVAR)
    65         K ^TMP("ORWORD",$J)
    66         ; init return record based on auto-accept
    67         I ORWMODE S LST(0)="2^"_ORIT ;verify on copy
    68         E  S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT
    69         S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
    70         I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O"
    71         I $L($G(OREVNTYP)) D
    72         . S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D
    73         .. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7)
    74         .. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt
    75         .. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt
    76         E  S ORCAT=TEMPCAT
    77         D SETUP^ORWDXM4 Q:+LST(0)=8
    78         S X="OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:"")
    79         I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) D  ;remove old values
    80         . K ORDIALOG($$PTR^ORCD(X),1)
    81         . I ORWMODE=2,$$DRAFT^ORWDX2(ORIT) Q  ;keep comments
    82         . K:ISXFER'["T" ORDIALOG($$PTR^ORCD("OR GTX WORD PROCESSING 1"),1)
    83         D SETUPS^ORWDXM4 ;moved to save space, expects X
    84         Q:+LST(0)=8
    85         I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q
    86         N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID
    87         S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0))
    88         S AUTOACK=$S($D(ORWPSWRG):0,1:1)
    89         S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ  D
    90         . S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
    91         . . ; skip if this is a child prompt
    92         . . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q
    93         . . ; set default for prompt, see if needs to be interactive
    94         . . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2)
    95         . . D SETITEM(DA,PROMPT,1,.MUSTASK)
    96         . . I MUSTASK S AUTOACK=0 Q
    97         . . ; iterate through the child items if parent and edit only
    98         . . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
    99         . . N CSEQ,CDA,CPROMPT,INST,ORQUIT
    100         . . S CSEQ=0 F  S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ  D  Q:$G(ORQUIT)
    101         . . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0))
    102         . . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2)
    103         . . . ; if req & no instances then need interaction
    104         . . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6),ORDIALOG'=IVFID,'$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0
    105         . . . S INST=0 F  S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST  D
    106         . . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS
    107         . . . . ; set default for each child prompt, if necessary
    108         . . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK)
    109         . . . . ; if no val & child prmpt required then need interaction
    110         . . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0
    111         N IVDLG
    112         S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
    113         I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORCAT="I") D
    114         . F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1)
    115         S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0
    116         I $$ISINPMED(ORIT) D
    117         .S LEVEL=$P(LST(0),U),DELAY=$S($P($G(OREVENT),";")>0:1,1:0)
    118         .I LEVEL=2!(ISIMO) D ADMTIME^ORWDXM2(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO)
    119         I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0
    120         S PROMPT=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT  D
    121         . I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q
    122         . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  D
    123         . . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST
    124         . . ; save word processing value
    125         . . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D
    126         . . .  M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST)
    127         . . ; save other value types
    128         . . E  S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST)
    129         I AUTOACK D
    130         . I ORWMODE S AUTOACK=2
    131         . I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2
    132         ;I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0
    133         I ORIMO,ORWMODE S AUTOACK=2
    134         ; added to accept Herbal/OTC/NonVA Med quick orders
    135         I $L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1
    136         ;I $G(^OR(100,+ORIT,0)),$P($G(^ORD(101.41,+$P(^OR(100,+ORIT,0),U,5),0)),U,8),$D(ORDIALOG("B","HERBAL/OTC/NON VA MEDICATION")) S AUTOACK=1
    137         I AUTOACK=2,$$ISMED(ORIT),(ORDIALOG=IVDLG),$$VERORD^ORWDXM3=0 S AUTOACK=0
    138         I AUTOACK=2 D VERTXT^ORWDXM2
    139         S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR)
    140         I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q"
    141         I ORWMODE=1 S $P(LST(0),U,4)="C"
    142         K ^TMP("ORWORD",$J)
    143         K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J)
    144         Q
    145 SETITEM(DA,PROMPT,INST,MUSTASK) ; set default value & return if must prompt
    146         N EDITONLY,Y,VALIV,XCODE
    147         S MUSTASK=0,EDITONLY=0,VALIV=0
    148         I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D
    149         . I $E(ORDIALOG(PROMPT,0))="W" D
    150         . . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)
    151         . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
    152         . E  S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)
    153         I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D
    154         . S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT)
    155         . ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!!
    156         ;
    157         ; skip if a value already exists for this prompt and not WP
    158         Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W")
    159         ; execute default action if no value in QO, checking EDITONLY afterwards
    160         I '$D(ORDIALOG(PROMPT,INST)) D
    161         . ;
    162         . ;Intermittent IV orders do not require a solution or an infusion rate
    163         . I PROMPT=$$PTR("INFUSION RATE"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q
    164         . I PROMPT=$$PTR("ORDERABLE ITEM"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q
    165         . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D
    166         . . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8)
    167         . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
    168         . E  D
    169         . . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7)))
    170         . . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y
    171         Q:VALIV=1
    172         Q:$G(EDITONLY)
    173         I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q
    174         I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q
    175         I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q
    176         I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q
    177         S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3)))
    178         I $L(XCODE) X XCODE Q:'$T
    179         S MUSTASK=1
    180         Q
    181 SUBCODE(X)      ; substitute code
    182         I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2"
    183         I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2"
    184         I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2"
    185         I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y"
    186         I X["I $$ASKURG^ORCDVBEC" Q "I 1"
    187         I X["K:$G(ORASK)" Q "I $G(ORASK)"
    188         Q X
    189 PTR(NAME)       ; -- Returns pointer to OR GTX NAME
    190         Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
    191         ;
    192 ISINPMED(IFN)   ;
    193         N PKG,RESULT,Y
    194         I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7)
    195         E  S PKG=$P($G(^OR(100,+IFN,0)),U,14)
    196         S Y=$$GET1^DIQ(9.4,+PKG_",",1)
    197         S RESULT=$S($E(Y,1,3)="PSJ":1,1:0)
    198         Q RESULT
    199         ;
    200 ISMED(IFN)      ; return 1 if pharmacy order dlg used
    201         N PKG
    202         I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7)
    203         E  S PKG=$P($G(^OR(100,+IFN,0)),U,14)
    204         Q $$NMSP^ORCD(PKG)="PS"
    205 SITEVAL()       ;return 1 if site does want the reason for study to carry through from past orders of this ordering session
    206         I $$GET^XPAR("ALL","OR RA RFS CARRY ON")=0 Q 0
    207         Q 1
    208 SVRPC(RET,X)    ;RPC FOR SITEVAL
    209         S RET=$$SITEVAL
    210         Q
     1ORWDXM1 ; SLC/KCM - Order Dialogs, Menus;2/19/03 ;11/15/2005
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215**;Dec 17, 1997
     3BLDQRSP(LST,ORIT,FLDS,ISIMO) ; Build responses for an order
     4 ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp
     5 ; LST(n)=verify text or reject text
     6 ; ORIT= ptr to 101.41 for quick order, 100 for copy
     7 ;       1   2    3    4   5   6    7    8        11-20
     8 ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables...
     9 ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change
     10 ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?)
     11 K ^TMP("ORWDXMQ",$J)
     12 N ORWMODE ; 0:Dialog,Quick 1:copy order 2:change order
     13 N TEMPCAT ; patient category from DPT file
     14 N ISXFER ; Transfer order?
     15 N ORIMO ;If IMO(inpatient medication on outpatient)
     16 N TEMPORIT
     17 S ORIMO=$G(ISIMO)
     18 S ORWMODE=0,ISXFER=""
     19 S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy for now
     20 S:$E(ORIT)="X" ORWMODE=2
     21 S TEMPORIT=ORIT
     22 I ORWMODE S ORIT=$E(ORIT,2,999)
     23 S LST(0)=""
     24 D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8  ;disable
     25 D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8  ;action
     26 I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8  ;no copy
     27 I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q  ;change
     28 I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q
     29 ;radilogy vars
     30 N ORIMTYPE
     31 ;blood bank vars
     32 N ORCOMP,ORTAS
     33 ;lab vars
     34 N LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH
     35 N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH
     36 ;pharmacy vars
     37 N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS
     38 N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94
     39 ;dietetics vars
     40 N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE
     41 ;consults vars
     42 N GMRCNOPD,GMRCNOAT,GMRCREAF
     43 ; setup general env
     44 N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR
     45 N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK
     46 N OREVNTYP
     47 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
     48 S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8)
     49 S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL
     50 S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1
     51 I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42)
     52 I $L($P(FLDS,U,7))  D
     53 . S OREVENT=$P(FLDS,U,7)
     54 . S OREVNTYP=$P(OREVENT,";",2)
     55 . S OREVENT("TS")=$P(OREVENT,";",3)
     56 . S OREVENT("EFFECTIVE")=$P(OREVENT,";",4)
     57 . S OREVENT=+$P(OREVENT,";",1)
     58 I 'ORWMODE D
     59 . D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path
     60 . S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action
     61 . D SETKEYV^ORWDXM3(KEYVAR)
     62 K ^TMP("ORWORD",$J)
     63 ; init return record based on auto-accept
     64 I ORWMODE S LST(0)="2^"_ORIT ;verify on copy
     65 E  S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT
     66 S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
     67 I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O"
     68 I $L($G(OREVNTYP)) D
     69 . S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D
     70 .. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7)
     71 .. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt
     72 .. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt
     73 E  S ORCAT=TEMPCAT
     74 D SETUP^ORWDXM4 Q:+LST(0)=8
     75 S X=$S($G(ORWP94):"OR GTX START DATE/TIME",1:"OR GTX START DATE")
     76 I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) K ORDIALOG($$PTR^ORCD(X),1)
     77 D SETUPS^ORWDXM4 ; moved to save space
     78 Q:+LST(0)=8
     79 I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q
     80 N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID
     81 S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0))
     82 S AUTOACK=$S($D(ORWPSWRG):0,1:1)
     83 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ  D
     84 . S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
     85 . . ; skip if this is a child prompt
     86 . . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q
     87 . . ; set default for prompt, see if needs to be interactive
     88 . . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2)
     89 . . D SETITEM(DA,PROMPT,1,.MUSTASK)
     90 . . I MUSTASK S AUTOACK=0 Q
     91 . . ; iterate through the child items if parent and edit only
     92 . . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
     93 . . N CSEQ,CDA,CPROMPT,INST,ORQUIT
     94 . . S CSEQ=0 F  S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ  D  Q:$G(ORQUIT)
     95 . . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0))
     96 . . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2)
     97 . . . ; if req & no instances then need interaction
     98 . . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6),ORDIALOG'=IVFID,'$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0
     99 . . . S INST=0 F  S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST  D
     100 . . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS
     101 . . . . ; set default for each child prompt, if necessary
     102 . . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK)
     103 . . . . ; if no val & child prmpt required then need interaction
     104 . . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0
     105 N IVDLG
     106 S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
     107 I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORCAT="I") D
     108 . F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1)
     109 S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0
     110 S PROMPT=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT  D
     111 . I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q
     112 . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  D
     113 . . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST
     114 . . ; save word processing value
     115 . . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D
     116 . . .  M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST)
     117 . . ; save other value types
     118 . . E  S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST)
     119 I AUTOACK D
     120 . I ORWMODE S AUTOACK=2
     121 . I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2
     122 I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0
     123 I ORIMO,ORWMODE S AUTOACK=2
     124 ; added to accept Herbal/OTC/NonVA Med quick orders
     125 I $L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1
     126 ;I $G(^OR(100,+ORIT,0)),$P($G(^ORD(101.41,+$P(^OR(100,+ORIT,0),U,5),0)),U,8),$D(ORDIALOG("B","HERBAL/OTC/NON VA MEDICATION")) S AUTOACK=1
     127 I AUTOACK=2 D VERTXT^ORWDXM2
     128 S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR)
     129 I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q"
     130 I ORWMODE=1 S $P(LST(0),U,4)="C"
     131 K ^TMP("ORWORD",$J)
     132 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J)
     133 Q
     134SETITEM(DA,PROMPT,INST,MUSTASK) ; set default value & return if must prompt
     135 N EDITONLY,Y,XCODE
     136 S MUSTASK=0,EDITONLY=0
     137 I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D
     138 . I $E(ORDIALOG(PROMPT,0))="W" D
     139 . . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)
     140 . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
     141 . E  S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)
     142 I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D
     143 . S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT)
     144 . ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!!
     145 ;
     146 ; skip if a value already exists for this prompt and not WP
     147 Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W")
     148 ; execute default action if no value in QO, checking EDITONLY afterwards
     149 I '$D(ORDIALOG(PROMPT,INST)) D
     150 . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D
     151 . . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8)
     152 . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
     153 . E  D
     154 . . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7)))
     155 . . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y
     156 Q:$G(EDITONLY)
     157 I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q
     158 I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q
     159 I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q
     160 I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q
     161 S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3)))
     162 I $L(XCODE) X XCODE Q:'$T
     163 S MUSTASK=1
     164 Q
     165SUBCODE(X) ; substitute code
     166 I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2"
     167 I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2"
     168 I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2"
     169 I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y"
     170 I X["I $$ASKURG^ORCDVBEC" Q "I 1"
     171 I X["K:$G(ORASK)" Q "I $G(ORASK)"
     172 Q X
     173PTR(NAME) ; -- Returns pointer to OR GTX NAME
     174 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
     175 ;
     176ISMED(IFN) ; return 1 if pharmacy order dlg used
     177 N PKG
     178 I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7)
     179 E  S PKG=$P($G(^OR(100,+IFN,0)),U,14)
     180 Q $$NMSP^ORCD(PKG)="PS"

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m

    r613 r623  
    1 ORWDXM2 ; SLC/KCM - Quick Orders ;04/25/2007
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 ADMTIME(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO)       ;
    5         N ADMLOC,INST,SCHLOC,SCHTYPE
    6         S ADMLOC=+$P($G(ORDIALOG("B","ADMINISTRATION TIMES")),U,2)
    7         I ADMLOC>0,ORDLOC>0,PATLOC'=ORDLOC D  Q
    8         .S INST=0 F  S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0  D
    9         ..S ORDIALOG(ADMLOC,INST)=""
    10         I ADMLOC>0,$S(ENCLOC'=PATLOC:1,ISIMO:1,DELAY:1,1:0) D  Q
    11         .S INST=0 F  S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0  D
    12         ..S ORDIALOG(ADMLOC,INST)=""
    13         S SCHLOC=+$P($G(ORDIALOG("B","SCHEDULE TYPE")),U,2) Q:SCHLOC'>0
    14         S INST=0 F  S INST=$O(ORDIALOG(SCHLOC,INST)) Q:+INST'>0  D
    15         .S SCHTYP=$G(ORDIALOG(SCHLOC,INST)) Q:SCHTYP=""
    16         .I $S(SCHTYP="P":1,SCHTYP="O":1,SCHTYP="OC":1,1:0),ADMLOC>0 S ORDIALOG(ADMLOC,INST)=""
    17         Q
    18         ;
    19 CLRRCL(OK)           ; clear ORECALL
    20         S OK=1
    21         K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J)
    22         Q
    23 VERTXT  ; set verify text for order
    24         N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,TEMP,ILST,SPACES
    25         N ISADMIN
    26         S ILST=0,$P(SPACES," ",31)=""
    27         S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0  D
    28         . S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
    29         . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0))
    30         . . S ISADMIN=$S(+OREVENT>0:0,ISIMO=1:0,$P($G(^ORD(101.41,$P(X0,U,2),0)),U)="OR GTX ADMIN TIMES":1,1:0)
    31         . . I ISADMIN=1,ORDLOC>0,ORDLOC'=PATLOC Q
    32         . . I $P(X0,U,9)["*",ISADMIN=0 Q
    33         . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) I CHILD,ISADMIN=0 Q
    34         . . Q:'PROMPT  S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST  ; no values
    35         . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
    36         . . I $E(ORDIALOG(PROMPT,0))="W" D
    37         . . . N IWP,WP,CNT
    38         . . . S IWP=0,CNT=0
    39         . . . F  S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP  D
    40         . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0)
    41         . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1)
    42         . . . I CNT>1 D
    43         . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0
    44         . . . . F  S IWP=$O(WP(IWP)) Q:'IWP  S ILST=ILST+1,LST(ILST)=WP(IWP)
    45         . . E  D
    46         . . . S TEMP=$$ITEM^ORCDLG(PROMPT,INST) I TEMP="" Q
    47         . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30)
    48         . . . ;S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST)
    49         . . . S LST(ILST)=LST(ILST)_TEMP
    50         . . Q:'MULT  Q:'$O(ORDIALOG(PROMPT,INST))  ; done
    51         . . F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST)
    52         D DISPLAY^ORWDBA3  ;for display of Billing Aware data from orig order
    53         Q
    54 RA      ; setup environment for radiology
    55         ; -- get imaging types based on display group of quick order and
    56         ;    setup list of imaging locations based on imaging type
    57         N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT
    58         S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3)
    59         S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0))
    60         D EN4^RAO7PC1(ITYPE,"ORY")
    61         S (IFN,CNT)=0 F  S IFN=$O(ORY(IFN)) Q:IFN'>0  D
    62         . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN
    63         I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC
    64         E  S ORIMLOC=CNT_"^1"
    65         S PROMPT=$O(^ORD(101.41,"B","OR GTX IMAGING LOCATION",0))
    66         I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC
    67         Q
    68 LR      ; setup environment for lab
    69         ; -- setup ORTIME, ORIMTIME & ORTEST arrays
    70         ;    setup ORMAX, ORDG, & ORCOLLCT variables
    71         N PROMPT,INST,EDITONLY
    72         D GETIMES^ORCDLR1  ; sets up ORTIME and ORIMTIME arrays
    73         S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
    74         S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),INST=1
    75         D LRTEST           ; sets up ORTEST array and ORDG
    76         S PROMPT=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
    77         I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1
    78         E  S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1
    79         I ORCOLLCT="I" D
    80         . S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
    81         . D LRICTMOK
    82         S PROMPT=$O(^ORD(101.41,"B","OR GTX ADMIN SCHEDULE",0))
    83         I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1)
    84         Q
    85 LRTEST  ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR)
    86         N OI,TST,DG
    87         S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI
    88         I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
    89         S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB"
    90         S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG
    91         Q
    92 LRRQCM()               ; return true if lab test has required comments
    93         I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP
    94         N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST
    95         S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN")
    96         S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0
    97         I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
    98         S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
    99         S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
    100         S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19)
    101         Q REQDCOMM
    102 LRASMP()              ; return true to ask collection sample (from ASKSAMP^ORCDLR)
    103         N DEFSAMP,SAMP0
    104         S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0))
    105         I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0
    106         I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask
    107         I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask
    108         I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice
    109         Q 1
    110 LRICTMOK               ;
    111         Q:'$D(ORDIALOG(PROMPT,1))
    112         N ORY
    113         D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1))
    114         I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)=""
    115         Q
    116 DO      ; setup environment for diet order
    117         ; partially copied from EN^ORCDFH
    118         I ORCAT'="I" D  Q
    119         . S ORQUIT=1
    120         . S LST(0)="8^0"
    121         . S LST(.5)="This type of diet may be entered for inpatients only."
    122         D EN^FHWOR8(+ORVP,.ORPARAM)          ; set FH ordering parameters
    123         S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
    124         N PROMPT,OI                          ; set NPO flag if NPO diet
    125         S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
    126         S OI=+$G(ORDIALOG(PROMPT,1))
    127         S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO")
    128         S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
    129         S X=$G(ORDIALOG(PROMPT,1)) I $L(X) D CNV^ORCDFH1 S ORDIALOG(PROMPT,1)=$G(X)
    130         Q
    131 EL      ; setup environment for early/late tray
    132         D EN^FHWOR8(+ORVP,.ORPARAM)          ; set FH ordering parameters
    133         S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
    134         D EN2^ORCDFH                         ; setup ORTIME array
    135         N PROMPT                             ; set ORMEAL,ORTRAY
    136         S PROMPT=$O(^ORD(101.41,"B","OR GTX MEAL",0))
    137         I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1)
    138         S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
    139         I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1)
    140         Q
    141 UD      ; setup environment for unit dose med
    142         I $G(ORWP94) G PS^ORWDPS3  ; if patch 94 installed
    143         ;
    144         D AUTHMED Q:$G(ORQUIT)  ; checks authorized to write meds
    145         N PROMPT,OI
    146         S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
    147         I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT)
    148         D INSTR^ORCDPS(OI)      ; sets up instructions, routes, etc.
    149         D CHOICES^ORCDPS("U")   ; gets list of dispense drugs       
    150         Q
    151 IV      ; setup environment for IV fluid
    152         D AUTHMED Q:$G(ORQUIT)  ; checks authorized to write meds
    153         ; sets up list of volumes if only one solution
    154         ; otherwise, let the dialog go interactive
    155         N PROMPT,INST,CNT,OI
    156         S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
    157         S (CNT,INST)=0
    158         F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  D  Q:$G(ORQUIT)
    159         . S CNT=CNT+1
    160         . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions
    161         I CNT=1 S INST=1 D VOLUME^ORCDPSIV
    162         S PROMPT=$O(^ORD(101.41,"B","OR GTX ADDITIVE",0))
    163         S INST=0
    164         F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  D  Q:$G(ORQUIT)
    165         . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives
    166         Q
    167 OP      ; setup environment for outpatient pharmacy
    168         I $G(ORWP94) G PS^ORWDPS3  ; if patch 94 installed
    169         ;
    170         D AUTHMED Q:$G(ORQUIT)       ; checks authorized to write meds
    171         N PROMPT,INST,CNT,OI
    172         S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),OI=0
    173         I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT)
    174         D:+OI INSTR^ORCDPS(OI)           ; sets up instructions, routes, etc.
    175         D CHOICES^ORCDPS("O")        ; gets list of dispense drugs     
    176         ; get defaults for drug, refills if only one dispense drug
    177         S PROMPT=$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
    178         S (CNT,INST)=0
    179         F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  S CNT=CNT+1
    180         I CNT=1 D
    181         . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0
    182         . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3)
    183         . S:'$L(OREFILLS) OREFILLS=11
    184         E  S ORCOMPLX=1,OREFILLS=11  ; force interactive on complex order
    185         S ORCOPAY=1                  ; ask SC if can't determine copay
    186         I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS
    187         Q
    188 AUTHMED ; sets ORQUIT if not authorized to write meds
    189         N NOAUTH,NAME
    190         D AUTH^ORWDPS32(.NOAUTH,ORNP)
    191         I +NOAUTH D
    192         . S ORQUIT=1
    193         . S LST(0)="8^0"
    194         . S NAME=$P($G(^VA(200,+ORNP,20)),U,2)
    195         . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1)
    196         . S LST(.5)=NAME_" is not authorized to write med orders."
    197         Q
    198 MEDACTV(USAGE)  ; sets ORQUIT if the orderable item is not active for a med
    199         Q:'$G(OI)  S USAGE=+$G(USAGE)
    200         I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D  Q
    201         . S ORQUIT=1,LST(0)="8^0"
    202         . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
    203         I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D  Q
    204         . S ORQUIT=1,LST(0)="8^0"
    205         . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore."
    206         Q
    207 SCHEDULD()      ; Is patient scheduled for PREOP (Imaging)
    208         I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date
    209         E  Q 0
    210         Q
     1ORWDXM2 ; SLC/KCM - Quick Orders ;11/25/02  09:49
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215**;Dec 17, 1997
     3 ;
     4CLRRCL(OK)      ; clear ORECALL
     5 S OK=1
     6 K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J)
     7 Q
     8VERTXT ; set verify text for order
     9 N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,ILST,SPACES
     10 S ILST=0,$P(SPACES," ",31)=""
     11 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0  D
     12 . S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
     13 . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0))
     14 . . Q:$P(X0,U,9)["*"  ; hidden prompt
     15 . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) Q:CHILD
     16 . . Q:'PROMPT  S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST  ; no values
     17 . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
     18 . . I $E(ORDIALOG(PROMPT,0))="W" D
     19 . . . N IWP,WP,CNT
     20 . . . S IWP=0,CNT=0
     21 . . . F  S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP  D
     22 . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0)
     23 . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1)
     24 . . . I CNT>1 D
     25 . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0
     26 . . . . F  S IWP=$O(WP(IWP)) Q:'IWP  S ILST=ILST+1,LST(ILST)=WP(IWP)
     27 . . E  D
     28 . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30)
     29 . . . S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST)
     30 . . Q:'MULT  Q:'$O(ORDIALOG(PROMPT,INST))  ; done
     31 . . F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST)
     32 D DISPLAY^ORWDBA3  ;for display of Billing Aware data from orig order
     33 Q
     34RA ; setup environment for radiology
     35 ; -- get imaging types based on display group of quick order and
     36 ;    setup list of imaging locations based on imaging type
     37 N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT
     38 S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3)
     39 S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0))
     40 D EN4^RAO7PC1(ITYPE,"ORY")
     41 S (IFN,CNT)=0 F  S IFN=$O(ORY(IFN)) Q:IFN'>0  D
     42 . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN
     43 I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC
     44 E  S ORIMLOC=CNT_"^1"
     45 S PROMPT=$O(^ORD(101.41,"AB","OR GTX IMAGING LOCATION",0))
     46 I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC
     47 Q
     48LR ; setup environment for lab
     49 ; -- setup ORTIME, ORIMTIME & ORTEST arrays
     50 ;    setup ORMAX, ORDG, & ORCOLLCT variables
     51 N PROMPT,INST,EDITONLY
     52 D GETIMES^ORCDLR1  ; sets up ORTIME and ORIMTIME arrays
     53 S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
     54 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)),INST=1
     55 D LRTEST           ; sets up ORTEST array and ORDG
     56 S PROMPT=$O(^ORD(101.41,"AB","OR GTX COLLECTION TYPE",0))
     57 I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1
     58 E  S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1
     59 I ORCOLLCT="I" D
     60 . S PROMPT=$O(^ORD(101.41,"AB","OR GTX START DATE/TIME",0))
     61 . D LRICTMOK
     62 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ADMIN SCHEDULE",0))
     63 I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1)
     64 Q
     65LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR)
     66 N OI,TST,DG
     67 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI
     68 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
     69 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB"
     70 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG
     71 Q
     72LRRQCM()        ; return true if lab test has required comments
     73 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP
     74 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST
     75 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN")
     76 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0
     77 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
     78 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
     79 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
     80 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19)
     81 Q REQDCOMM
     82LRASMP()       ; return true to ask collection sample (from ASKSAMP^ORCDLR)
     83 N DEFSAMP,SAMP0
     84 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0))
     85 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0
     86 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask
     87 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask
     88 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice
     89 Q 1
     90LRICTMOK        ;
     91 Q:'$D(ORDIALOG(PROMPT,1))
     92 N ORY
     93 D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1))
     94 I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)=""
     95 Q
     96DO ; setup environment for diet order
     97 ; partially copied from EN^ORCDFH
     98 I ORCAT'="I" D  Q
     99 . S ORQUIT=1
     100 . S LST(0)="8^0"
     101 . S LST(.5)="This type of diet may be entered for inpatients only."
     102 D EN^FHWOR8(+ORVP,.ORPARAM)          ; set FH ordering parameters
     103 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
     104 N PROMPT,OI                          ; set NPO flag if NPO diet
     105 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
     106 S OI=+$G(ORDIALOG(PROMPT,1))
     107 S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO")
     108 Q
     109EL ; setup environment for early/late tray
     110 D EN^FHWOR8(+ORVP,.ORPARAM)          ; set FH ordering parameters
     111 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
     112 D EN2^ORCDFH                         ; setup ORTIME array
     113 N PROMPT                             ; set ORMEAL,ORTRAY
     114 S PROMPT=$O(^ORD(101.41,"AB","OR GTX MEAL",0))
     115 I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1)
     116 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
     117 I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1)
     118 Q
     119UD ; setup environment for unit dose med
     120 I $G(ORWP94) G PS^ORWDPS3  ; if patch 94 installed
     121 ;
     122 D AUTHMED Q:$G(ORQUIT)  ; checks authorized to write meds
     123 N PROMPT,OI
     124 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
     125 I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT)
     126 D INSTR^ORCDPS(OI)      ; sets up instructions, routes, etc.
     127 D CHOICES^ORCDPS("U")   ; gets list of dispense drugs       
     128 Q
     129IV ; setup environment for IV fluid
     130 D AUTHMED Q:$G(ORQUIT)  ; checks authorized to write meds
     131 ; sets up list of volumes if only one solution
     132 ; otherwise, let the dialog go interactive
     133 N PROMPT,INST,CNT,OI
     134 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
     135 S (CNT,INST)=0
     136 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  D  Q:$G(ORQUIT)
     137 . S CNT=CNT+1
     138 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions
     139 I CNT=1 S INST=1 D VOLUME^ORCDPSIV
     140 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ADDITIVE",0))
     141 S INST=0
     142 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  D  Q:$G(ORQUIT)
     143 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives
     144 Q
     145OP ; setup environment for outpatient pharmacy
     146 I $G(ORWP94) G PS^ORWDPS3  ; if patch 94 installed
     147 ;
     148 D AUTHMED Q:$G(ORQUIT)       ; checks authorized to write meds
     149 N PROMPT,INST,CNT,OI
     150 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)),OI=0
     151 I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT)
     152 D:+OI INSTR^ORCDPS(OI)           ; sets up instructions, routes, etc.
     153 D CHOICES^ORCDPS("O")        ; gets list of dispense drugs     
     154 ; get defaults for drug, refills if only one dispense drug
     155 S PROMPT=$O(^ORD(101.41,"AB","OR GTX DISPENSE DRUG",0))
     156 S (CNT,INST)=0
     157 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST  S CNT=CNT+1
     158 I CNT=1 D
     159 . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0
     160 . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3)
     161 . S:'$L(OREFILLS) OREFILLS=11
     162 E  S ORCOMPLX=1,OREFILLS=11  ; force interactive on complex order
     163 S ORCOPAY=1                  ; ask SC if can't determine copay
     164 I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS
     165 Q
     166AUTHMED ; sets ORQUIT if not authorized to write meds
     167 N NOAUTH,NAME
     168 D AUTH^ORWDPS32(.NOAUTH,ORNP)
     169 I +NOAUTH D
     170 . S ORQUIT=1
     171 . S LST(0)="8^0"
     172 . S NAME=$P($G(^VA(200,+ORNP,20)),U,2)
     173 . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1)
     174 . S LST(.5)=NAME_" is not authorized to write med orders."
     175 Q
     176MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med
     177 Q:'$G(OI)  S USAGE=+$G(USAGE)
     178 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D  Q
     179 . S ORQUIT=1,LST(0)="8^0"
     180 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
     181 I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D  Q
     182 . S ORQUIT=1,LST(0)="8^0"
     183 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore."
     184 Q
     185SCHEDULD() ; Is patient scheduled for PREOP (Imaging)
     186 I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date
     187 E  Q 0
     188 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM3.m

    r613 r623  
    1 ORWDXM3 ; SLC/KCM/JLI - Quick Orders ;05/27/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,185,187,190,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 VALCOUNT(NAME,ORDIALOG) ;
    5         N COUNT,IEN,NUM
    6         S NUM=0,COUNT=0
    7         S IEN=$P($G(ORDIALOG("B",NAME)),U,2) Q:IEN'>0
    8         F  S NUM=$O(ORDIALOG(IEN,NUM)) Q:+NUM'>0  S COUNT=COUNT+1
    9         Q COUNT
    10         ;
    11 ISMISSFL(ORDIALOG,IVTYPE)       ;
    12         N ADDCNT,RESULT,STRCNT
    13         S RESULT=0
    14         S ADDCNT=$$VALCOUNT("ADDITIVE",.ORDIALOG)
    15         S STRCNT=$$VALCOUNT("STRENGTH",.ORDIALOG)
    16         I IVTYPE'="I",ADDCNT'=STRCNT S RESULT=1
    17         I IVTYPE="I",ADDCNT=0 S RESULT=1
    18         Q RESULT
    19         ;
    20 KEYVAR(DLG)      ; Parse entry action for key variables & return in string
    21         ; RV=CollTp^Samp^Spec^CollDt^Urg^Sched^NoComm^NoDiag^NoProv^NoRsn
    22         N XCODE,RV,POS,Z
    23         S XCODE=$G(^ORD(101.41,DLG,3)),RV=""
    24         I '$L(XCODE) Q ""
    25         S POS=$F(XCODE,"LRFZX=")    I POS S $P(RV,U,1)=$$VALUE(XCODE,POS)
    26         S POS=$F(XCODE,"LRFSAMP=")  I POS S $P(RV,U,2)=$$VALUE(XCODE,POS)
    27         S POS=$F(XCODE,"LRFSPEC=")  I POS S $P(RV,U,3)=$$VALUE(XCODE,POS)
    28         S POS=$F(XCODE,"LRFDATE=")  I POS S $P(RV,U,4)=$$VALUE(XCODE,POS)
    29         S POS=$F(XCODE,"LRFURG=")   I POS S $P(RV,U,5)=$$VALUE(XCODE,POS)
    30         S POS=$F(XCODE,"LRFSCH=")   I POS S $P(RV,U,6)=$$VALUE(XCODE,POS)
    31         S POS=$F(XCODE,"PSJNOPC=")  I POS S $P(RV,U,7)=$$VALUE(XCODE,POS)
    32         S POS=$F(XCODE,"GMRCNOPD=") I POS S $P(RV,U,8)=$$VALUE(XCODE,POS)
    33         S POS=$F(XCODE,"GMRCNOAT=") I POS S $P(RV,U,9)=$$VALUE(XCODE,POS)
    34         S POS=$F(XCODE,"GMRCREAF=") I POS S $P(RV,U,10)=$$VALUE(XCODE,POS)
    35         S POS=$F(XCODE,"ORFORGET=") I POS D
    36         . ; need to change this so that it is executed in SETKEYV so
    37         . ; that it is executed each time menu is revisited
    38         . N ORFORGET S ORFORGET=$$VALUE(XCODE,POS)
    39         . I ORFORGET K ^TMP("ORECALL",$J,+ORFORGET)
    40         . E  K ^TMP("ORECALL",$J)
    41         Q RV
    42 VALUE(STR,BEG)  ; Return value of "var=" (copied from ORCONVRT)
    43         N X,Y,I S X=$E(STR,BEG,999),Y=""
    44         S:$E(X)="""" X=$E(X,2,999) ; strip leading "
    45         F I=1:1:$L(X) S Z=$E(X,I) Q:(Z=",")!(Z=" ")!(Z="""")  S Y=Y_Z
    46         Q $TR(Y,U,"")
    47         ;
    48 SETKEYV(X)           ; Set the key variables based on contents of X
    49         I $L($P(X,U,1))  S LRFZX=$P(X,U,1)
    50         I $L($P(X,U,2))  S LRFSAMP=$P(X,U,2)
    51         I $L($P(X,U,3))  S LRFSPEC=$P(X,U,3)
    52         I $L($P(X,U,4))  S LRFDATE=$P(X,U,4)
    53         I $L($P(X,U,5))  S LRFURG=$P(X,U,5)
    54         I $L($P(X,U,6))  S LRFSCH=$P(X,U,6)
    55         I $L($P(X,U,7))  S PSJNOPC=$P(X,U,7)
    56         I $L($P(X,U,8))  S GMRCNOPD=$P(X,U,8)
    57         I $L($P(X,U,9))  S GMRCNOAT=$P(X,U,9)
    58         I $L($P(X,U,10)) S GMRCREAF=$P(X,U,10)
    59         Q
    60 DLGINFO(IEN,MODE)          ; return information about a dialog
    61         ; IEN=DlgIEN or ORIFN, MODE=0:Dlg,1:Copy,2:Change
    62         ; RESULT=DlgIEN^DlgType^FormID^DGrp
    63         ; If MODE="1;T",don't check "PS MEDS" for transfer order
    64         ; PSMDGP=1: Unit/Dose  Group
    65         ; PSMDGP=2: OutPatient Group
    66         N X0,DLGIEN,TYP,FID,DGRP,PSMDGP,ISXF
    67         S PSMDGP=0,ISXF=""
    68         S ISXF=$P(MODE,";",2)
    69         S MODE=+MODE
    70         S DLGIEN=IEN I MODE,(ISXF'="T") D
    71         . S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5)
    72         . I $P(^ORD(101.41,DLGIEN,0),U)="PS MEDS" D
    73         . . N PTCAT S PTCAT=$P($G(^OR(100,+IEN,0)),U,12)
    74         . . I PTCAT="I" S DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)),PSMDGP=1
    75         . . I PTCAT="O" S DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)),PSMDGP=2
    76         I MODE,(ISXF="T") S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5)
    77         S X0=$G(^ORD(101.41,DLGIEN,0)),TYP=$P(X0,U,4),DGRP=$P(X0,U,5)
    78         I MODE S DGRP=+$P($G(^OR(100,+IEN,0)),U,11)
    79         ;JD NEW START 11/13/02
    80         I DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) S PSMDGP=1
    81         I DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)) S PSMDGP=2
    82         ;JD NEW END 11/13/02
    83         ; for copy or change, if the base dialog has changed, use it's info
    84         I MODE,$G(ORDIALOG),(+DLGIEN'=+ORDIALOG),(PSMDGP=0) D
    85         . S DLGIEN=+ORDIALOG,DGRP=$P(^ORD(101.41,+ORDIALOG,0),U,5)
    86         D FORMID^ORWDXM(.FID,DLGIEN)
    87         Q DLGIEN_U_TYP_U_FID_U_DGRP
    88         ;
    89 CHKDSBL(LST,ID,MODE)     ; return message if dialog disabled
    90         ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change
    91         ; LST=QL_REJECT + disabled message or unchanged
    92         S DLGIEN=+ID I MODE S DLGIEN=+$P($G(^OR(100,+ID,0)),U,5)
    93         S X0=$G(^ORD(101.41,DLGIEN,0)),X=$P(X0,U,3)
    94         I '$L(X),($P(X0,U,4)="Q") D  ; check default dialog
    95         . S DLGIEN=+$$DEFDLG^ORWDXQ($P(X0,U,5))
    96         . S X=$P($G(^ORD(101.41,DLGIEN,0)),U,3)
    97         I $L(X) D
    98         . I MODE D GETTXT^ORWORR(.LST,ID) S LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -"
    99         . S LST(0)="8^0",LST(.5)="Dialog Disabled:  "_X
    100         Q
    101 CHKVACT(LST,ID,MODE,ORNP)        ; return message if action not valid
    102         ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change
    103         ; LST=QL_REJECT + invalid action message or unchanged
    104         Q:'MODE  ; not an action on an order
    105         N X,ACT S ACT=$S(MODE=1:"RW",MODE=2:"XX",1:"")
    106         D VALID^ORWDXA(.X,ID,ACT,ORNP)
    107         I $L(X) D GETTXT^ORWORR(.LST,ID) D
    108         . S LST(0)="8^0",LST(.5)=X,LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -"
    109         Q
    110 CHKCOPY(LST,ID,FLDS)     ; return message if can't copy this order
    111         ; ID=ORIFN;ACT FLDS=EventType in 7th piece
    112         ; LST=QL_REJECT + cannot copy message or unchanged
    113         I "^A^D^T^"'[(U_$E($P(FLDS,U,7))_U) Q             ; not event delayed
    114         N PKG S PKG=$P($G(^OR(100,+ID,0)),U,14)
    115         S PKG=$$NMSP^ORCD(PKG) I PKG="OR"!(PKG="PS") Q    ; xfer meds, generics
    116         N ORWCAT S ORWCAT=$P($G(^OR(100,+ID,0)),U,12)
    117         I ORWCAT="I",("^A^T^"[(U_$E($P(FLDS,U,7))_U)) Q   ; admit, xfer inpt
    118         I ORWCAT="O",$E($P(FLDS,U,7))="D" Q               ; discharge outpt
    119         D GETTXT^ORWORR(.LST,ID)
    120         I ORWCAT="I" S LST(.5)="inpatient order to outpatient -"
    121         I ORWCAT="O" S LST(.5)="outpatient order to inpatient -"
    122         S:$D(LST(.5)) LST(.5)="Cannot copy the following "_LST(.5)
    123         S LST(0)="8^0",LST(.7)=""
    124         Q
    125 BLD4CHG(LST,ID,FLDS)     ; build responses for an edit
    126         ; ID=ORIFN;ACT FLDS=unused right now
    127         ; LST(0)=Qlvl^RespID(XOrderID)^DlgIEN^DlgType^FormID^DGrp
    128         N OIDX,OI,CNT
    129         S (OI,OIDX,CNT)=0
    130         S:$D(^OR(100,+ID,4.5,"ID","ORDERABLE")) OIDX=$O(^OR(100,+ID,4.5,"ID","ORDERABLE",0))
    131         I $D(^OR(100,+ID,4.5,OIDX)) D
    132         . F  S CNT=$O(^OR(100,+ID,4.5,OIDX,CNT)) Q:'CNT  D
    133         . . S OI=^(CNT) D VALDOI
    134         I +LST(0)=8 S LST(.5)="You can not change this order." Q
    135         S LST(0)="0^X"_ID_U_$$DLGINFO(+ID,2)
    136         S $P(LST(0),U,4)="X"
    137         Q
    138 GETIVTYP()      ;
    139         N RESULT,TYPEIEN
    140         S RESULT=""
    141         S TYPEIEN=$O(^ORD(101.41,"B","OR GTX IV TYPE","")) I TYPEIEN'>0 Q RESULT
    142         S RESULT=$G(ORDIALOG(TYPEIEN,1))
    143         Q RESULT
    144         ;
    145 VALDOI  ; Validate the Orderable Items
    146         N ORQUIT,ORPS
    147         I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D
    148         . S ORQUIT=1
    149         . S LST(0)="8^0"
    150         I $D(ORQUIT) Q:ORQUIT
    151         S ORPS=$G(^ORD(101.43,+OI,"PS"))
    152         I $P(ORPS,U,1,4)="0^0^0^0",($P(ORPS,U,7)=0) S LST(0)="8^0"
    153         Q
    154 VERORD()        ;
    155         N INFUSE,INFUID,PASSIV,SUCC,TYPE
    156         S SUCC=0
    157         S TYPE=$$GETIVTYP
    158         I TYPE="" Q SUCC
    159         S PASSIV=$$IVRTECHK
    160         I PASSIV=0 Q SUCC
    161         S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0))
    162         S INFUSE=$G(ORDIALOG(INFUID,1))
    163         S SUCC=$$VALINF(TYPE,INFUSE)
    164         Q SUCC
    165         ;
    166 VALINF(TYPE,INFUSE)     ;
    167         N SUCC
    168         S SUCC=0
    169         I TYPE="I" D  Q SUCC
    170         .I INFUSE["INFUSE OVER" S SUCC=1 Q
    171         .I $L(INFUSE)>4 Q
    172         Q 1
    173         ;
    174 VALQO(IFN)      ;Check to see if it's a good QO med
    175         ;If it's an IV QO: check if infusion rate entered
    176         ;If it's an UD QO: check if dosage entered
    177         ;regular order treated as good QO
    178         ;
    179         I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1
    180         N ODP,ODG,INFUID,INFUSE,DSAGEID,SUCC,PASSIV,TYPE
    181         S SUCC=0
    182         S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5)
    183         S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3)
    184         I ODP'["PS" Q 1
    185         ;check infusion rate for IV QO
    186         I ODG="IV RX"!(ODG="TPN") D
    187         . S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0))
    188         . S TYPE=$$GETIVTYP
    189         . I TYPE="" Q
    190         . I $D(ORDIALOG(INFUID,1)) D
    191         . . I TYPE="I" D  Q
    192         . . . S INFUSE=$G(ORDIALOG(INFUID,1))
    193         . . . I INFUSE="" Q
    194         . . . I INFUSE["INFUSE OVER" S SUCC=1 Q
    195         . . . I $L(INFUSE)>4 Q
    196         . . . I +INFUSE>0 S INFUSE="INFUSE OVER "_INFUSE_" Minutes"
    197         . . . S ORDIALOG(INFUID,1)=INFUSE,SUCC=1
    198         . . S SUCC=1
    199         . I '$D(ORDIALOG(INFUID,1)),TYPE="I" S SUCC=1
    200         . S PASSIV=$$IVRTECHK
    201         . I SUCC=0 Q
    202         . I PASSIV=0 S SUCC=0
    203         . I SUCC=1,$$ISMISSFL(.ORDIALOG,TYPE)=1 S SUCC=0
    204         ;check dosage for UD QO
    205         I (ODP="PSJ")!(ODP="PSO"),ODG'="IV RX",ODG'="TPN" D
    206         . S DSAGEID=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
    207         . I $D(ORDIALOG(DSAGEID,1)) S SUCC=1
    208         Q SUCC
    209         ;
    210 IVRTECHK()      ;
    211         N RTIEN,RTVALUE,RESULT
    212         N CNT,NUM,ORDERIDS,OIIEN,OTYPE,ROUTE
    213         S CNT=0,RESULT=0
    214         S RTIEN=+$P($G(ORDIALOG("B","ROUTE")),U,2) I RTIEN'>0 Q RESULT
    215         S RTVALUE=+$G(ORDIALOG(RTIEN,1)) I RTVALUE'>0 Q RESULT
    216         F OTYPE="SOLUTION","ADDITIVE" D
    217         .S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D
    218         ..S NUM=0 F  S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0  I +$G(ORDIALOG(OIIEN,NUM))>0 D
    219         ...S CNT=CNT+1,ORDERIDS(CNT)=ORDIALOG(OIIEN,NUM)
    220         I $D(ORDERIDS)=0 Q
    221         S ROUTE=$$IVQOVAL^ORWDPS33(.ORDERIDS,RTVALUE)
    222         I ROUTE="" S ORDIALOG(RTIEN,1)=ROUTE
    223         I ROUTE'="" S RESULT=1
    224         ;K ^TMP($J,"ORWDXM3 IVRTECHK")
    225         ;D ALL^PSS51P2(RTVALUE,,,,"ORWDXM3 IVRTECHK")
    226         ;I +^TMP($J,"ORWDXM3 IVRTECHK",RTVALUE,6)'=1 S ORDIALOG(RTIEN,1)="",RESULT=0
    227         ;K ^TMP($J,"ORWDXM3 IVRTECHK")
    228         Q RESULT
    229         ;
    230 ISUDQO(ORY,DLGID)       ;True: is unit dose quick order
    231         S ORY=0
    232         Q:'$D(^ORD(101.41,DLGID,0))
    233         N CLODGRP,UDGRP1,UDGRP2,DLGTYP,DLGGRP
    234         S UDGRP1=$O(^ORD(100.98,"B","UD RX",0))
    235         S UDGRP2=$O(^ORD(100.98,"B","I RX",0))
    236         S CLODGRP=$O(^ORD(100.98,"B","CLINIC ORDERS",""))
    237         S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4)
    238         S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5)
    239         I (DLGTYP="Q"),((DLGGRP=UDGRP1)!(DLGGRP=UDGRP2)!(DLGGRP=CLODGRP)) S ORY=1
    240         Q
     1ORWDXM3 ; SLC/KCM/JLI - Quick Orders ;10:42 AM 6/20/2002
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,185,187,190,195,215**;Dec 17, 1997
     3 ;
     4KEYVAR(DLG)  ; Parse entry action for key variables & return in string
     5 ; RV=CollTp^Samp^Spec^CollDt^Urg^Sched^NoComm^NoDiag^NoProv^NoRsn
     6 N XCODE,RV,POS,Z
     7 S XCODE=$G(^ORD(101.41,DLG,3)),RV=""
     8 I '$L(XCODE) Q ""
     9 S POS=$F(XCODE,"LRFZX=")    I POS S $P(RV,U,1)=$$VALUE(XCODE,POS)
     10 S POS=$F(XCODE,"LRFSAMP=")  I POS S $P(RV,U,2)=$$VALUE(XCODE,POS)
     11 S POS=$F(XCODE,"LRFSPEC=")  I POS S $P(RV,U,3)=$$VALUE(XCODE,POS)
     12 S POS=$F(XCODE,"LRFDATE=")  I POS S $P(RV,U,4)=$$VALUE(XCODE,POS)
     13 S POS=$F(XCODE,"LRFURG=")   I POS S $P(RV,U,5)=$$VALUE(XCODE,POS)
     14 S POS=$F(XCODE,"LRFSCH=")   I POS S $P(RV,U,6)=$$VALUE(XCODE,POS)
     15 S POS=$F(XCODE,"PSJNOPC=")  I POS S $P(RV,U,7)=$$VALUE(XCODE,POS)
     16 S POS=$F(XCODE,"GMRCNOPD=") I POS S $P(RV,U,8)=$$VALUE(XCODE,POS)
     17 S POS=$F(XCODE,"GMRCNOAT=") I POS S $P(RV,U,9)=$$VALUE(XCODE,POS)
     18 S POS=$F(XCODE,"GMRCREAF=") I POS S $P(RV,U,10)=$$VALUE(XCODE,POS)
     19 S POS=$F(XCODE,"ORFORGET=") I POS D
     20 . ; need to change this so that it is executed in SETKEYV so
     21 . ; that it is executed each time menu is revisited
     22 . N ORFORGET S ORFORGET=$$VALUE(XCODE,POS)
     23 . I ORFORGET K ^TMP("ORECALL",$J,+ORFORGET)
     24 . E  K ^TMP("ORECALL",$J)
     25 Q RV
     26VALUE(STR,BEG) ; Return value of "var=" (copied from ORCONVRT)
     27 N X,Y,I S X=$E(STR,BEG,999),Y=""
     28 S:$E(X)="""" X=$E(X,2,999) ; strip leading "
     29 F I=1:1:$L(X) S Z=$E(X,I) Q:(Z=",")!(Z=" ")!(Z="""")  S Y=Y_Z
     30 Q $TR(Y,U,"")
     31 ;
     32SETKEYV(X)      ; Set the key variables based on contents of X
     33 I $L($P(X,U,1))  S LRFZX=$P(X,U,1)
     34 I $L($P(X,U,2))  S LRFSAMP=$P(X,U,2)
     35 I $L($P(X,U,3))  S LRFSPEC=$P(X,U,3)
     36 I $L($P(X,U,4))  S LRFDATE=$P(X,U,4)
     37 I $L($P(X,U,5))  S LRFURG=$P(X,U,5)
     38 I $L($P(X,U,6))  S LRFSCH=$P(X,U,6)
     39 I $L($P(X,U,7))  S PSJNOPC=$P(X,U,7)
     40 I $L($P(X,U,8))  S GMRCNOPD=$P(X,U,8)
     41 I $L($P(X,U,9))  S GMRCNOAT=$P(X,U,9)
     42 I $L($P(X,U,10)) S GMRCREAF=$P(X,U,10)
     43 Q
     44DLGINFO(IEN,MODE)    ; return information about a dialog
     45 ; IEN=DlgIEN or ORIFN, MODE=0:Dlg,1:Copy,2:Change
     46 ; RESULT=DlgIEN^DlgType^FormID^DGrp
     47 ; If MODE="1;T",don't check "PS MEDS" for transfer order
     48 ; PSMDGP=1: Unit/Dose  Group
     49 ; PSMDGP=2: OutPatient Group
     50 N X0,DLGIEN,TYP,FID,DGRP,PSMDGP,ISXF
     51 S PSMDGP=0,ISXF=""
     52 S ISXF=$P(MODE,";",2)
     53 S MODE=+MODE
     54 S DLGIEN=IEN I MODE,(ISXF'="T") D
     55 . S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5)
     56 . I $P(^ORD(101.41,DLGIEN,0),U)="PS MEDS" D
     57 . . N PTCAT S PTCAT=$P($G(^OR(100,+IEN,0)),U,12)
     58 . . I PTCAT="I" S DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)),PSMDGP=1
     59 . . I PTCAT="O" S DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)),PSMDGP=2
     60 I MODE,(ISXF="T") S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5)
     61 S X0=$G(^ORD(101.41,DLGIEN,0)),TYP=$P(X0,U,4),DGRP=$P(X0,U,5)
     62 I MODE S DGRP=+$P($G(^OR(100,+IEN,0)),U,11)
     63 ;JD NEW START 11/13/02
     64 I DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) S PSMDGP=1
     65 I DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)) S PSMDGP=2
     66 ;JD NEW END 11/13/02
     67 ; for copy or change, if the base dialog has changed, use it's info
     68 I MODE,$G(ORDIALOG),(+DLGIEN'=+ORDIALOG),(PSMDGP=0) D
     69 . S DLGIEN=+ORDIALOG,DGRP=$P(^ORD(101.41,+ORDIALOG,0),U,5)
     70 D FORMID^ORWDXM(.FID,DLGIEN)
     71 Q DLGIEN_U_TYP_U_FID_U_DGRP
     72 ;
     73CHKDSBL(LST,ID,MODE)  ; return message if dialog disabled
     74 ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change
     75 ; LST=QL_REJECT + disabled message or unchanged
     76 S DLGIEN=+ID I MODE S DLGIEN=+$P($G(^OR(100,+ID,0)),U,5)
     77 S X0=$G(^ORD(101.41,DLGIEN,0)),X=$P(X0,U,3)
     78 I '$L(X),($P(X0,U,4)="Q") D  ; check default dialog
     79 . S DLGIEN=+$$DEFDLG^ORWDXQ($P(X0,U,5))
     80 . S X=$P($G(^ORD(101.41,DLGIEN,0)),U,3)
     81 I $L(X) D
     82 . I MODE D GETTXT^ORWORR(.LST,ID) S LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -"
     83 . S LST(0)="8^0",LST(.5)="Dialog Disabled:  "_X
     84 Q
     85CHKVACT(LST,ID,MODE,ORNP)  ; return message if action not valid
     86 ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change
     87 ; LST=QL_REJECT + invalid action message or unchanged
     88 Q:'MODE  ; not an action on an order
     89 N X,ACT S ACT=$S(MODE=1:"RW",MODE=2:"XX",1:"")
     90 D VALID^ORWDXA(.X,ID,ACT,ORNP)
     91 I $L(X) D GETTXT^ORWORR(.LST,ID) D
     92 . S LST(0)="8^0",LST(.5)=X,LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -"
     93 Q
     94CHKCOPY(LST,ID,FLDS)  ; return message if can't copy this order
     95 ; ID=ORIFN;ACT FLDS=EventType in 7th piece
     96 ; LST=QL_REJECT + cannot copy message or unchanged
     97 I "^A^D^T^"'[(U_$E($P(FLDS,U,7))_U) Q             ; not event delayed
     98 N PKG S PKG=$P($G(^OR(100,+ID,0)),U,14)
     99 S PKG=$$NMSP^ORCD(PKG) I PKG="OR"!(PKG="PS") Q    ; xfer meds, generics
     100 N ORWCAT S ORWCAT=$P($G(^OR(100,+ID,0)),U,12)
     101 I ORWCAT="I",("^A^T^"[(U_$E($P(FLDS,U,7))_U)) Q   ; admit, xfer inpt
     102 I ORWCAT="O",$E($P(FLDS,U,7))="D" Q               ; discharge outpt
     103 D GETTXT^ORWORR(.LST,ID)
     104 I ORWCAT="I" S LST(.5)="inpatient order to outpatient -"
     105 I ORWCAT="O" S LST(.5)="outpatient order to inpatient -"
     106 S:$D(LST(.5)) LST(.5)="Cannot copy the following "_LST(.5)
     107 S LST(0)="8^0",LST(.7)=""
     108 Q
     109BLD4CHG(LST,ID,FLDS)  ; build responses for an edit
     110 ; ID=ORIFN;ACT FLDS=unused right now
     111 ; LST(0)=Qlvl^RespID(XOrderID)^DlgIEN^DlgType^FormID^DGrp
     112 N OIDX,OI,CNT
     113 S (OI,OIDX,CNT)=0
     114 S:$D(^OR(100,+ID,4.5,"ID","ORDERABLE")) OIDX=$O(^OR(100,+ID,4.5,"ID","ORDERABLE",0))
     115 I $D(^OR(100,+ID,4.5,OIDX)) D
     116 . F  S CNT=$O(^OR(100,+ID,4.5,OIDX,CNT)) Q:'CNT  D
     117 . . S OI=^(CNT) D VALDOI
     118 I +LST(0)=8 S LST(.5)="You can not change this order." Q
     119 S LST(0)="0^X"_ID_U_$$DLGINFO(+ID,2)
     120 S $P(LST(0),U,4)="X"
     121 Q
     122VALDOI ; Validate the Orderable Items
     123 N ORQUIT,ORPS
     124 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D
     125 . S ORQUIT=1
     126 . S LST(0)="8^0"
     127 I $D(ORQUIT) Q:ORQUIT
     128 S ORPS=$G(^ORD(101.43,+OI,"PS"))
     129 I $P(ORPS,U,1,4)="0^0^0^0",($P(ORPS,U,7)=0) S LST(0)="8^0"
     130 Q
     131VALQO(IFN) ;Check to see if it's a good QO med
     132 ;If it's an IV QO: check if infusion rate entered
     133 ;If it's an UD QO: check if dosage entered
     134 ;regular order treated as good QO
     135 ;
     136 I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1
     137 N ODP,ODG,INFUID,DSAGEID,SUCC
     138 S SUCC=0
     139 S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5)
     140 S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3)
     141 ;check infusion rate for IV QO
     142 I ODG="IV RX"!(ODG="TPN") D
     143 . S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0))
     144 . I $D(ORDIALOG(INFUID,1)) S SUCC=1
     145 ;check dosage for UD QO
     146 I (ODP="PSJ")!(ODP="PSO"),ODG'="IV RX",ODG'="TPN" D
     147 . S DSAGEID=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
     148 . I $D(ORDIALOG(DSAGEID,1)) S SUCC=1
     149 Q SUCC
     150ISUDQO(ORY,DLGID) ;True: is unit dose quick order
     151 S ORY=0
     152 Q:'$D(^ORD(101.41,DLGID,0))
     153 N CLODGRP,UDGRP1,UDGRP2,DLGTYP,DLGGRP
     154 S UDGRP1=$O(^ORD(100.98,"B","UD RX",0))
     155 S UDGRP2=$O(^ORD(100.98,"B","I RX",0))
     156 S CLODGRP=$O(^ORD(100.98,"B","CLINIC ORDERS",""))
     157 S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4)
     158 S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5)
     159 I (DLGTYP="Q"),((DLGGRP=UDGRP1)!(DLGGRP=UDGRP2)!(DLGGRP=CLODGRP)) S ORY=1
     160 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m

    r613 r623  
    1 ORWDXR  ; SLC/KCM/JDL - Utilites for Order Actions ;5/30/06  14:50
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213,243**;Dec 17, 1997;Build 242
    3         ;
    4 ACTDCREA(DCIEN) ; Valid DC Reason
    5         N X
    6         S X=$G(^ORD(100.03,DCIEN,0))
    7         I $P(X,U,4) Q 0
    8         I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q 0
    9         I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q 0
    10         Q 1
    11         ;
    12 ISREL(VAL,ORIFN)        ; Return true if an order has been released
    13         N STS S STS=$P(^OR(100,+ORIFN,3),U,3)
    14         S VAL=$S(STS=10:0,STS=11:0,1:1)  ; false if delayed or unreleased order
    15         Q
    16 RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order
    17         N ORDG
    18         N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG
    19         N ORDIALOG,PRMT,X0
    20         N FSTDOSE,FST
    21         S (FSTDOSE,FST)=0
    22         I '$D(CPLX) S CPLX=0
    23         I '$G(ORAPPT) S ORAPPT=""
    24         S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
    25         S X0=^OR(100,+ORIFN,0)
    26         S ORDG=$P(X0,U,11)
    27         S ORPKG=$P(X0,U,14)
    28         I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK")
    29         I $P(X0,U,5)["101.41," D                        ; version 3
    30         . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
    31         . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
    32         . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW")
    33         . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1)
    34         E  D                                            ; version 2.5 generic
    35         . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
    36         . D GETDLG^ORCD(ORDIALOG)
    37         . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
    38         . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
    39         . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
    40         . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
    41         . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
    42         I +FLDS(1)=999 D  ; generic order
    43         . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2)
    44         . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3)
    45         I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D
    46         . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
    47         . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12)
    48         . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
    49         . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
    50         . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
    51         . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2)
    52         . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP)       ; dflt doses
    53         . D D1^ORCDPS2  ; set up ORDOSE
    54         . S DRUG=$G(ORDOSE("DD",+ORDRUG))
    55         . I DRUG,ORCAT="O" D RESETID^ORCDPS
    56         . D SIG^ORCDPS2
    57         I +FLDS(1)=140 D  ; outpatient meds
    58         . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt
    59         . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4)
    60         . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5)
    61         . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
    62         . K ^TMP("ORWORD",$J,PRMT,1)
    63         . S I=1 F  S I=$O(FLDS(I)) Q:'I  S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I)
    64         . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
    65         . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
    66         . N SIG,PI,X S SIG=$$PTR^ORCD("OR GTX SIG")
    67         . S PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS"),X=$$STR(PI)
    68         . I $L(X),$$STR(SIG)[X S ORDIALOG(PI,"FORMAT")="@" ;PI in Sig
    69         D RN^ORCSAVE
    70         S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
    71         Q
    72 RNWFLDS(LST,ORIFN)      ; Return fields for renew action
    73         ; LST(0)=RenewType^Start^Stop^Refills^Pickup  LST(n)=Comments
    74         N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI
    75         S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14)
    76         S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3)
    77         S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0)
    78         I +LST(0)=140 D
    79         . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")
    80         . ;D WPVAL(.LST,ORIFN,"COMMENT")
    81         I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
    82         ; make sure start/stop times are relative times, otherwise use NOW, no Stop
    83         I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW"
    84         I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)=""
    85         ;NEW STUFF AFTER THIS LINE OR*3*243
    86         S $P(LST(0),U,9)=0
    87         S OROI=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0))
    88         Q:'OROI
    89         S OROI=$G(^OR(100,+ORIFN,4.5,OROI,1))
    90         Q:'OROI
    91         S $P(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI)
    92         ; add to LST node specifying if patient of ORIFN passes clozapine lab tests
    93         I $P(LST(0),U,9) D
    94         .N ORY,ORDFN,ORTMP
    95         .S ORTMP=LST(0)
    96         .K LST
    97         .S LST(0)=ORTMP
    98         .S ORDFN=$P(^OR(100,ORIFN,0),U,2)
    99         .I $P(ORDFN,";",2)'="DPT(" Q
    100         .S ORDFN=+ORDFN
    101         .D ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E")
    102         .M LST(1)=ORY
    103         Q
    104 VAL(ORIFN,ID)   ; Return value for order response
    105         N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
    106         Q $G(^OR(100,ORIFN,4.5,DA,1))
    107 WPVAL(TXT,ORIFN,ID)     ; Return word processing value
    108         N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
    109         S I=0 F  S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I  S TXT(I)=^(I,0)
    110         Q
    111 STR(PTR)        ; -- Return word processing text as long string for comparison
    112         N X,Y,I,ARRY
    113         S ARRY=$G(ORDIALOG(+$G(PTR),1)) Q:'$L(ARRY) ""
    114         S I=+$O(@ARRY@(0)),Y=$$UP^XLFSTR($G(@ARRY@(I,0)))
    115         F  S I=+$O(@ARRY@(I)) Q:'I  S X=$G(@ARRY@(I,0)),Y=Y_$$UP^XLFSTR(X)
    116         S Y=$TR(Y," ") ;remove all spaces, compare only text
    117         Q Y
    118 CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR)   ; Return error if can't sign/release order
    119         N ORACT,ORWERR
    120         ; begin case
    121         S ORACT=""
    122         I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1
    123         I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1
    124         I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1
    125         I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES"
    126 XC1     ; end case
    127         S ORWERR=""
    128         I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR=""
    129         Q ORWERR
    130 GTORITM(Y,ORIFN)        ;-- Get back the orderable item IEN
    131         S ORIFN=+ORIFN
    132         S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
    133         Q
    134 GETPKG(Y,IFN)   ;Get package for an order
    135         N ORDERID,PKGID
    136         Q:+IFN<1
    137         S ORDERID=+IFN,Y=""
    138         S PKGID=$P(^OR(100,ORDERID,0),U,14)
    139         S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
    140         Q
    141 ISCPLX(ORY,ORID)        ; 1: is complex order 0: is not
    142         Q:'$D(^OR(100,+ORID,0))
    143         N PKG
    144         S PKG=$P($G(^OR(100,+ORID,0)),U,14)
    145         S PKG=$$NMSP^ORCD(PKG)
    146         I PKG'="PS" Q
    147         N NUMCHDS,NOWID,NOWVAL
    148         S (NOWVAL,NOWID)=0
    149         S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4)
    150         I NUMCHDS>2 S ORY=1 Q
    151         I NUMCHDS=2 D
    152         . S ORY=1
    153         . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
    154         . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1))
    155         I NOWVAL=1 S ORY=0 Q
    156         Q
    157 ORCPLX(ORY,ORID,ORACT)  ;Return children orders of the complex order
    158         Q:'$D(^OR(100,+ORID,0))
    159         N PKG,LACT,OELACT,ISNOW
    160         S PKG=$P($G(^OR(100,+ORID,0)),U,14)
    161         S PKG=$$NMSP^ORCD(PKG)
    162         I PKG'="PS" Q
    163         N CHLDCNT,IDX,X3
    164         S (CHLDCNT,IDX)=0
    165         S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4)
    166         I 'CHLDCNT Q
    167         F  S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX  D
    168         . S (LACT,OELACT,ISNOW)=0
    169         . D ISNOW(.ISNOW,IDX)
    170         . Q:ISNOW
    171         . S X3=$G(^OR(100,IDX,3))
    172         . S LACT=$P(X3,U,7)
    173         . F  S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT
    174         . S:OELACT>LACT LACT=OELACT
    175         . S ORY(IDX)=IDX_";"_LACT
    176         Q
    177 CANRN(ORY,ORID) ; Check conjunction for renew.
    178         ; All conjunctioni = "And" return 1
    179         ; Has a "Then" return 0
    180         Q:'$G(^OR(100,+ORID,0))
    181         N PKG
    182         S PKG=$P($G(^OR(100,+ORID,0)),U,14)
    183         S PKG=$$NMSP^ORCD(PKG)
    184         I PKG'="PS" Q
    185         N INDX,INDY,CANRENEW
    186         S INDX=0
    187         S CANRENEW=1
    188         N CHID
    189         S CHID=0 F  S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID  D
    190         . N ORSTS,ACTIVE S ORSTS=0
    191         . S ORSTS=$P($G(^OR(100,CHID,3)),U,3)
    192         . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0))
    193         . I ACTIVE'=ORSTS S CANRENEW=0
    194         I 'CANRENEW S ORY=CANRENEW Q
    195         F  S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX  D
    196         . S INDY=0 F  S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY  D
    197         . . I $G(^(INDY))="T" S CANRENEW=0 Q
    198         . I CANRENEW=0 Q
    199         S ORY=CANRENEW
    200         Q
    201 ISNOW(ORY,ORID) ; Is first time now order?
    202         N SCH
    203         Q:'$D(^OR(100,+ORID,0))
    204         S SCH=""
    205         S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
    206         S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1))
    207         S:SCH="NOW" ORY=1
    208         Q
     1ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions ;5/6/04  14:50
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213**;Dec 17, 1997
     3 ;
     4ISREL(VAL,ORIFN) ; Return true if an order has been released
     5 N STS S STS=$P(^OR(100,+ORIFN,3),U,3)
     6 S VAL=$S(STS=10:0,STS=11:0,1:1)  ; false if delayed or unreleased order
     7 Q
     8RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order
     9 N ORDG
     10 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG
     11 N ORDIALOG,PRMT,X0
     12 N FSTDOSE,FST
     13 S (FSTDOSE,FST)=0
     14 I '$D(CPLX) S CPLX=0
     15 I '$G(ORAPPT) S ORAPPT=""
     16 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
     17 S X0=^OR(100,+ORIFN,0)
     18 S ORDG=$P(X0,U,11)
     19 S ORPKG=$P(X0,U,14)
     20 I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK")
     21 I $P(X0,U,5)["101.41," D                        ; version 3
     22 . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
     23 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
     24 . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW")
     25 . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1)
     26 E  D                                            ; version 2.5 generic
     27 . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
     28 . D GETDLG^ORCD(ORDIALOG)
     29 . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
     30 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
     31 . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
     32 . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
     33 . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
     34 I +FLDS(1)=999 D  ; generic order
     35 . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2)
     36 . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3)
     37 I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D
     38 . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
     39 . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12)
     40 . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
     41 . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
     42 . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
     43 . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2)
     44 . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP)       ; dflt doses
     45 . D D1^ORCDPS2  ; set up ORDOSE
     46 . S DRUG=$G(ORDOSE("DD",+ORDRUG))
     47 . I DRUG,ORCAT="O" D RESETID^ORCDPS
     48 . D SIG^ORCDPS2
     49 I +FLDS(1)=140 D  ; outpatient meds
     50 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt
     51 . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4)
     52 . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5)
     53 . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
     54 . K ^TMP("ORWORD",$J,PRMT,1)
     55 . S I=1 F  S I=$O(FLDS(I)) Q:'I  S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I)
     56 . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
     57 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
     58 D RN^ORCSAVE
     59 S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
     60 Q
     61RNWFLDS(LST,ORIFN)      ; Return fields for renew action
     62 ; LST(0)=RenewType^Start^Stop^Refills^Pickup  LST(n)=Comments
     63 N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS
     64 S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14)
     65 S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3)
     66 S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0)
     67 I +LST(0)=140 D
     68 . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")
     69 . D WPVAL(.LST,ORIFN,"COMMENT")
     70 I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
     71 ; make sure start/stop times are relative times, otherwise use NOW, no Stop
     72 I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW"
     73 I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)=""
     74 Q
     75VAL(ORIFN,ID)   ; Return value for order response
     76 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
     77 Q $G(^OR(100,ORIFN,4.5,DA,1))
     78WPVAL(TXT,ORIFN,ID)    ; Return word processing value
     79 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
     80 S I=0 F  S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I  S TXT(I)=^(I,0)
     81 Q
     82CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order
     83 N ORACT,ORWERR
     84 ; begin case
     85 S ORACT=""
     86 I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1
     87 I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1
     88 I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1
     89 I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES"
     90XC1 ; end case
     91 S ORWERR=""
     92 I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR=""
     93 Q ORWERR
     94GTORITM(Y,ORIFN)        ;-- Get back the orderable item IEN
     95 S ORIFN=+ORIFN
     96 S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
     97 Q
     98GETPKG(Y,IFN) ;Get package for an order
     99 N ORDERID,PKGID
     100 Q:+IFN<1
     101 S ORDERID=+IFN,Y=""
     102 S PKGID=$P(^OR(100,ORDERID,0),U,14)
     103 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
     104 Q
     105ISCPLX(ORY,ORID) ; 1: is complex order 0: is not
     106 Q:'$D(^OR(100,+ORID,0))
     107 N PKG
     108 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
     109 S PKG=$$NMSP^ORCD(PKG)
     110 I PKG'="PS" Q
     111 N NUMCHDS,NOWID,NOWVAL
     112 S (NOWVAL,NOWID)=0
     113 S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4)
     114 I NUMCHDS>2 S ORY=1 Q
     115 I NUMCHDS=2 D
     116 . S ORY=1
     117 . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
     118 . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1))
     119 I NOWVAL=1 S ORY=0 Q
     120 Q
     121ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order
     122 Q:'$D(^OR(100,+ORID,0))
     123 N PKG,LACT,OELACT,ISNOW
     124 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
     125 S PKG=$$NMSP^ORCD(PKG)
     126 I PKG'="PS" Q
     127 N CHLDCNT,IDX,X3
     128 S (CHLDCNT,IDX)=0
     129 S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4)
     130 I 'CHLDCNT Q
     131 F  S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX  D
     132 . S (LACT,OELACT,ISNOW)=0
     133 . D ISNOW(.ISNOW,IDX)
     134 . Q:ISNOW
     135 . S X3=$G(^OR(100,IDX,3))
     136 . S LACT=$P(X3,U,7)
     137 . F  S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT
     138 . S:OELACT>LACT LACT=OELACT
     139 . S ORY(IDX)=IDX_";"_LACT
     140 Q
     141CANRN(ORY,ORID) ; Check conjunction for renew.
     142 ; All conjunctioni = "And" return 1
     143 ; Has a "Then" return 0
     144 Q:'$G(^OR(100,+ORID,0))
     145 N PKG
     146 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
     147 S PKG=$$NMSP^ORCD(PKG)
     148 I PKG'="PS" Q
     149 N INDX,INDY,CANRENEW
     150 S INDX=0
     151 S CANRENEW=1
     152 N CHID
     153 S CHID=0 F  S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID  D
     154 . N ORSTS,ACTIVE S ORSTS=0
     155 . S ORSTS=$P($G(^OR(100,CHID,3)),U,3)
     156 . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0))
     157 . I ACTIVE'=ORSTS S CANRENEW=0
     158 I 'CANRENEW S ORY=CANRENEW Q
     159 F  S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX  D
     160 . S INDY=0 F  S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY  D
     161 . . I $G(^(INDY))="T" S CANRENEW=0 Q
     162 . I CANRENEW=0 Q
     163 S ORY=CANRENEW
     164 Q
     165ISNOW(ORY,ORID) ; Is first time now order?
     166 N SCH
     167 Q:'$D(^OR(100,+ORID,0))
     168 S SCH=""
     169 S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
     170 S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1))
     171 S:SCH="NOW" ORY=1
     172 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB.m

    r613 r623  
    1 ORWDXVB ;slc/dcm - Order dialog utilities for Blood Bank ;12/7/05  17:11
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242
    3         ;
    4         ; DBIA 2503   RR^LR7OR1   ^TMP("LRRR",$J)
    5         ;
    6 GETPAT(ORX,DFN,ORL)         ;Get Patient data from VBECS
    7         ;Needs patient DFN and Location (ORL)
    8         N ORSTN,DIV
    9         S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3)
    10         D OEAPI^VBECA3(.ORX,DFN,ORSTN)
    11         Q
    12 PTINFO(OROOT,ORX)             ;Format patient BB info
    13         Q:'$D(ORX)
    14         D PTINFO^ORWDXVB1
    15         Q
    16 RESULTS(OROOT,DFN,ORX)   ;Get test results
    17         Q:'$O(ORX(0))  ;ORX contains a list of tests to retrieve results for
    18         N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I,ORZ
    19         S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80
    20         S OROOT=$NA(^TMP("ORVBEC",$J))
    21         K ^TMP("ORVBEC",$J)
    22         D LN
    23         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"RECENT LAB RESULTS:",.CCNT)
    24         D LN
    25         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Test    Result    Units      Range     Collected       Accession     Sts",.CCNT)
    26         D LN
    27         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----    ------    -----      -----     ---------       ---------     ---",.CCNT)
    28         S ORT=0 F  S ORT=$O(ORX(ORT)) Q:'ORT  S ORTST=$P(ORX(ORT),"^",1) D
    29         . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1)  ;DBIA 2503
    30         . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP)
    31         . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN)
    32         . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP
    33         . D LN
    34         . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(ORZ,"^",15),.CCNT)_$$S^ORU4(8,CCNT,$J($P(ORZ,"^",2),7),.CCNT)_$$S^ORU4(16,CCNT,$P(ORZ,"^",3),.CCNT)_$$S^ORU4(19,CCNT,$P(ORZ,"^",4),.CCNT)_$$S^ORU4(30,CCNT,$P(ORZ,"^",5),.CCNT)
    35         . S ^(0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(40,CCNT,$$DATETIME^ORCHTAB(ORTDT),.CCNT)_$$S^ORU4(56,CCNT,$P(ORZ,"^",16),.CCNT)_$$S^ORU4(71,CCNT,$P(ORZ,"^",6),.CCNT)
    36         . S ORCOM=$P(ORTMP,",",1,5)_",""N""" ;check for comments
    37         . F  S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=ORCOM  D
    38         .. D LN
    39         .. S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,@ORTMP,.CCNT)
    40         K ^TMP("LRRR",$J)
    41         Q
    42 RAW(OROOT,DFN,ORX)       ;Get RAW test results
    43         Q:'$O(ORX(0))  ;ORX contains a list of tests to retrieve results for
    44         N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I
    45         S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80
    46         S OROOT=$NA(^TMP("ORVBEC",$J))
    47         K ^TMP("ORVBEC",$J)
    48         S ORT=0 F  S ORT=$O(ORX(ORT)) Q:'ORT  S ORTST=$P(ORX(ORT),"^",1) D
    49         . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1)
    50         . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP)
    51         . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN)
    52         . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP
    53         . D LN
    54         . S ^TMP("ORVBEC",$J,GCNT,0)=$P(ORZ,"^",1,6)_"^"_ORTDT
    55         K ^TMP("LRRR",$J)
    56         Q
    57 SURG(OROOT,ORX) ;Get list of surgeries
    58         N I,CNT,X
    59         S (I,CNT)=0
    60         F  S I=$O(ORX("SURGERY",I)) Q:'I  S X=$G(ORX("SURGERY",I)) D
    61         . S CNT=CNT+1,OROOT(CNT)=X_U_X
    62         Q
    63 LN      ;Increment counts
    64         S GCNT=GCNT+1,CCNT=1
    65         Q
    66 PATINFO(OROOT,DFN,LOC)    ;Test ^TMP global output
    67         N ORX
    68         D GETPAT(.ORX,DFN,LOC)
    69         I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^"))
    70         D PTINFO(.OROOT,.ORX)
    71         ;S I=0 F  S I=$O(@OROOT@(I)) Q:'I  W !,^(I,0)
    72         ;K @OROOT
    73         Q
    74 GETALL(OROOT,DFN,LOC)   ;Get all data in one call and let the GUI divide it up
    75         N ORX,INFO,CNT,I,J,K
    76         S OROOT=$NA(^TMP("ORVBECINFO",$J)),CNT=1
    77         D GETPAT(.ORX,DFN,LOC)
    78         ;S ^TMP("ORVBECINFO",$J,CNT)="~RAWDATA",I=0
    79         ;F  S I=$O(ORX(I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)=ORX(I)
    80         I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("SPECIMEN")
    81         I $L($G(ORX("ABORH"))) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~ABORH",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("ABORH")
    82         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TYPE AND SCREEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"ID","1;99VBC",0))
    83         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~OTHER",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"ID","6;99VBC",0))
    84         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMENS",I=0
    85         F  S I=$O(ORX(I)) Q:'I  S J="" F  S J=$O(ORX(I,J)) Q:J=""  I J="SPECIMEN" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX(I,J)
    86         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TESTS",I=0
    87         F  S I=$O(ORX(I)) Q:'I  S J="" F  S J=$O(ORX(I,J)) Q:J=""  I J="TEST" S K=0 F  S K=$O(ORX(I,J,K)) Q:'K  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K)
    88         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MSBOS",I=0
    89         F  S I=$O(ORX(I)) Q:'I  S J="" F  S J=$O(ORX(I,J)) Q:J=""  I J="MSBOS" S K=0 F  S K=$O(ORX(I,J,K)) Q:'K  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K),$P(^(CNT),"^",4)=+$P(ORX(I,J,K),"^",2)
    90         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SURGERIES",I=0
    91         F  S I=$O(ORX("SURGERY",I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX("SURGERY",I)
    92         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~URGENCIES",I=""
    93         F  S I=$O(^ORD(101.42,"S.VBEC",I)) Q:I=""  S J=0 F  S J=$O(^ORD(101.42,"S.VBEC",I,J)) Q:'J  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_J_"^"_I
    94         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MODIFIERS",I=""
    95         N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS MODIFIERS","I")
    96         F  S I=$O(ORMODS(I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I)
    97         ;F I="W^Washed","I^Irradiated","L^Leuko Reduced","V^Volume Reduced","D^Divided","E^Leuko Reduced/Irradiated" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I
    98         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~REASONS",I=""
    99         N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS REASON FOR REQUEST","I")
    100         F  S I=$O(ORMODS(I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I)
    101         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~INFO"
    102         D PTINFO(.INFO,.ORX)
    103         S I=0 F  S I=$O(^TMP("ORVBEC",$J,I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_^TMP("ORVBEC",$J,I,0)
    104         S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TNS ORDERS"
    105         N ORMODS D PULL^ORWDXVB2(.ORMODS,DFN)
    106         S I=0 F  S I=$O(ORMODS(I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I)
    107         K ^TMP("ORVBEC",$J)
    108         Q
    109 STATALOW(OROOT,DFN)     ;Allow stat for ORES ORELSE users
    110         S OROOT=$D(^XUSEC("ORES",DUZ))!($D(^XUSEC("ORELSE",DUZ)))
    111         Q
    112 NURSADMN(OROOT) ;Suppress Nursing Adiminstration Order Prompt
    113         S OROOT=+$$GET^XPAR("DIV^SYS^PKG","OR VBECS SUPPRESS NURS ADMIN")
    114         Q
    115 VBTNS(RETURN)   ;RPC to get Days back to check for Type & Screen order
    116         S RETURN=$$GET^XPAR("ALL","ORWDXVB VBECS TNS CHECK",1,"I")
    117         Q
    118 COMPORD(OROOT)  ;Get sequence order of Blood Components
    119         N ORLIST,I,X
    120         D GETLST^XPAR(.ORLIST,"ALL","OR VBECS COMPONENT ORDER")
    121         S I=0 F  S I=$O(ORLIST(I)) Q:'I  S X=ORLIST(I) I $D(^ORD(101.43,$P(X,"^",2),0)) S OROOT(I)=$P(X,"^",2)_"^"_$P(^(0),"^",1)_"^"_$P(^(0),"^",1)
    122         Q
    123 SUBCHK(OROOT,TSTNM)     ;Check to see if selected test is a Blood Component or a Diagnostic Test
    124         S OROOT=""
    125         Q:'$L($G(TSTNM))
    126         I $O(^ORD(101.43,"S.VBT",TSTNM,0)) S OROOT="t"
    127         I $O(^ORD(101.43,"S.VBC",TSTNM,0)) S OROOT="c"
    128         Q
    129 TESTR   ;Test results call
    130         N ORX
    131         S ORX(3)="3" ;HGB
    132         S ORX(4)="4" ;HCT
    133         S ORX(1)="1" ;WBC
    134         S ORX(113)="113" ;FERRITIN
    135         D RESULTS(.OROOT,66,.ORX)
    136         S I=0 F  S I=$O(@OROOT@(I)) Q:'I  W !,^(I,0)
    137         K @OROOT
    138         Q
     1ORWDXVB ;slc/dcm - Order dialog utilities for Blood Bank ;12/7/05  17:11
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997
     3 ;
     4 ; DBIA 2503   RR^LR7OR1   ^TMP("LRRR",$J)
     5 ;
     6GETPAT(ORX,DFN,ORL)     ;Get Patient data from VBECS
     7 ;Needs patient DFN and Location (ORL)
     8 N ORSTN,DIV
     9 S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3)
     10 D OEAPI^VBECA3(.ORX,DFN,ORSTN)
     11 Q
     12PTINFO(OROOT,ORX)       ;Format patient BB info
     13 Q:'$D(ORX)
     14 D PTINFO^ORWDXVB1
     15 Q
     16RESULTS(OROOT,DFN,ORX)  ;Get test results
     17 Q:'$O(ORX(0))  ;ORX contains a list of tests to retrieve results for
     18 N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I,ORZ
     19 S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80
     20 S OROOT=$NA(^TMP("ORVBEC",$J))
     21 K ^TMP("ORVBEC",$J)
     22 D LN
     23 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"RECENT LAB RESULTS:",.CCNT)
     24 D LN
     25 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Test    Result    Units      Range     Collected       Accession     Sts",.CCNT)
     26 D LN
     27 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----    ------    -----      -----     ---------       ---------     ---",.CCNT)
     28 S ORT=0 F  S ORT=$O(ORX(ORT)) Q:'ORT  S ORTST=$P(ORX(ORT),"^",1) D
     29 . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1)  ;DBIA 2503
     30 . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP)
     31 . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN)
     32 . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP
     33 . D LN
     34 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(ORZ,"^",15),.CCNT)_$$S^ORU4(8,CCNT,$J($P(ORZ,"^",2),7),.CCNT)_$$S^ORU4(16,CCNT,$P(ORZ,"^",3),.CCNT)_$$S^ORU4(19,CCNT,$P(ORZ,"^",4),.CCNT)_$$S^ORU4(30,CCNT,$P(ORZ,"^",5),.CCNT)
     35 . S ^(0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(40,CCNT,$$DATETIME^ORCHTAB(ORTDT),.CCNT)_$$S^ORU4(56,CCNT,$P(ORZ,"^",16),.CCNT)_$$S^ORU4(71,CCNT,$P(ORZ,"^",6),.CCNT)
     36 . S ORCOM=$P(ORTMP,",",1,5)_",""N""" ;check for comments
     37 . F  S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=ORCOM  D
     38 .. D LN
     39 .. S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,@ORTMP,.CCNT)
     40 K ^TMP("LRRR",$J)
     41 Q
     42RAW(OROOT,DFN,ORX)  ;Get RAW test results
     43 Q:'$O(ORX(0))  ;ORX contains a list of tests to retrieve results for
     44 N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I
     45 S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80
     46 S OROOT=$NA(^TMP("ORVBEC",$J))
     47 K ^TMP("ORVBEC",$J)
     48 S ORT=0 F  S ORT=$O(ORX(ORT)) Q:'ORT  S ORTST=$P(ORX(ORT),"^",1) D
     49 . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1)
     50 . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP)
     51 . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN)
     52 . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP
     53 . D LN
     54 . S ^TMP("ORVBEC",$J,GCNT,0)=$P(ORZ,"^",1,6)_"^"_ORTDT
     55 K ^TMP("LRRR",$J)
     56 Q
     57SURG(OROOT,ORX) ;Get list of surgeries
     58 N I,CNT,X
     59 S (I,CNT)=0
     60 F  S I=$O(ORX("SURGERY",I)) Q:'I  S X=$G(ORX("SURGERY",I)) D
     61 . S CNT=CNT+1,OROOT(CNT)=X_U_X
     62 Q
     63LN ;Increment counts
     64 S GCNT=GCNT+1,CCNT=1
     65 Q
     66PATINFO(OROOT,DFN,LOC)   ;Test ^TMP global output
     67 N ORX
     68 D GETPAT(.ORX,DFN,LOC)
     69 I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^"))
     70 D PTINFO(.OROOT,.ORX)
     71 ;S I=0 F  S I=$O(@OROOT@(I)) Q:'I  W !,^(I,0)
     72 ;K @OROOT
     73 Q
     74GETALL(OROOT,DFN,LOC) ;Get all data in one call and let the GUI divide it up
     75 N ORX,INFO,CNT,I,J,K
     76 S OROOT=$NA(^TMP("ORVBECINFO",$J)),CNT=1
     77 D GETPAT(.ORX,DFN,LOC)
     78 ;S ^TMP("ORVBECINFO",$J,CNT)="~RAWDATA",I=0
     79 ;F  S I=$O(ORX(I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)=ORX(I)
     80 I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("SPECIMEN")
     81 I $L($G(ORX("ABORH"))) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~ABORH",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("ABORH")
     82 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TYPE AND SCREEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"S.VBEC","TYPE & SCREEN",0))
     83 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMENS",I=0
     84 F  S I=$O(ORX(I)) Q:'I  S J="" F  S J=$O(ORX(I,J)) Q:J=""  I J="SPECIMEN" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX(I,J)
     85 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TESTS",I=0
     86 F  S I=$O(ORX(I)) Q:'I  S J="" F  S J=$O(ORX(I,J)) Q:J=""  I J="TEST" S K=0 F  S K=$O(ORX(I,J,K)) Q:'K  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K)
     87 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MSBOS",I=0
     88 F  S I=$O(ORX(I)) Q:'I  S J="" F  S J=$O(ORX(I,J)) Q:J=""  I J="MSBOS" S K=0 F  S K=$O(ORX(I,J,K)) Q:'K  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K),$P(^(CNT),"^",4)=+$P(ORX(I,J,K),"^",2)
     89 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SURGERIES",I=0
     90 F  S I=$O(ORX("SURGERY",I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX("SURGERY",I)
     91 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~URGENCIES",I=""
     92 F  S I=$O(^ORD(101.42,"S.VBEC",I)) Q:I=""  S J=0 F  S J=$O(^ORD(101.42,"S.VBEC",I,J)) Q:'J  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_J_"^"_I
     93 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MODIFIERS",I=""
     94 N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS MODIFIERS","I")
     95 F  S I=$O(ORMODS(I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I)
     96 ;F I="W^Washed","I^Irradiated","L^Leuko Reduced","V^Volume Reduced","D^Divided","E^Leuko Reduced/Irradiated" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I
     97 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~INFO",I=0
     98 D PTINFO(.INFO,.ORX)
     99 F  S I=$O(^TMP("ORVBEC",$J,I)) Q:'I  S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_^TMP("ORVBEC",$J,I,0)
     100 K ^TMP("ORVBEC",$J)
     101 Q
     102STATALOW(OROOT,DFN) ;Allow stat for ORES ORELSE users
     103 S OROOT=$D(^XUSEC("ORES",DUZ))!($D(^XUSEC("ORELSE",DUZ)))
     104 Q
     105COMPORD(OROOT) ;Get sequence order of Blood Components
     106 N ORLIST,I,X
     107 D GETLST^XPAR(.ORLIST,"ALL","OR VBECS COMPONENT ORDER")
     108 S I=0 F  S I=$O(ORLIST(I)) Q:'I  S X=ORLIST(I) I $D(^ORD(101.43,$P(X,"^",2),0)) S OROOT(I)=$P(X,"^",2)_"^"_$P(^(0),"^",1)_"^"_$P(^(0),"^",1)
     109 Q
     110TESTR ;Test results call
     111 N ORX
     112 S ORX(3)="3" ;HGB
     113 S ORX(4)="4" ;HCT
     114 S ORX(1)="1" ;WBC
     115 S ORX(113)="113" ;FERRITIN
     116 D RESULTS(.OROOT,66,.ORX)
     117 S I=0 F  S I=$O(@OROOT@(I)) Q:'I  W !,^(I,0)
     118 K @OROOT
     119 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB1.m

    r613 r623  
    1 ORWDXVB1        ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04  09:31 ;12/7/05  17:20
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242
    3         ;
    4 PTINFO  ;Format patient BB info
    5         N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND
    6         S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80
    7         S OROOT=$NA(^TMP("ORVBEC",$J))
    8         K ^TMP("ORVBEC",$J)
    9         ;
    10         I +$G(ORX("ERROR")) D ERROR^ORWDXVB2 Q
    11         ; Patient Demographics
    12         D LN
    13         I '$D(ORX("PATIENT")) D  Q
    14         . D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    15         . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(10,CCNT,"There is no previous record of this patient in VBECS.",.CCNT) Q
    16         ;
    17         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Name",.CCNT)_$$S^ORU4(27,CCNT,"SSN",.CCNT)_$$S^ORU4(42,CCNT,"ABO/Rh",.CCNT)
    18         D LN
    19         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----",.CCNT)_$$S^ORU4(27,CCNT,"---",.CCNT)_$$S^ORU4(42,CCNT,"------",.CCNT) D
    20         . D LN
    21         . S X=ORX("PATIENT"),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(X,"^",3)_", "_$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$P(X,"^",4),.CCNT)
    22         . I $P(ORX("ABORH"),"^")']"" S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,"unknown",.CCNT) Q
    23         . S X=ORX("ABORH"),^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,$$STRIP^XLFSTR($P(X,"^")," ")_" "_$S($$STRIP^XLFSTR($P(X,"^",2)," ")="P":"Pos",$$STRIP^XLFSTR($P(X,"^",2)," ")="N":"Neg",1:"unknown"),.CCNT) Q
    24         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    25         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    26         ;
    27         ; Available Specimens
    28         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Lab Specimen ID",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date",.CCNT)
    29         D LN
    30         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------------",.CCNT) D
    31         . I '$D(ORX("SPECIMEN")) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
    32         . D LN
    33         . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(ORX("SPECIMEN"),"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME^ORCHTAB($P(ORX("SPECIMEN"),"^")),.CCNT) Q
    34         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    35         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    36         ;
    37         ; Antibodies Identified section
    38         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Antibodies Identified",.CCNT)
    39         D LN
    40         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT) D
    41         . I '$O(ORX("ABHIS",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
    42         . D LN
    43         . S ABFND=0
    44         . S I=0 F  S I=$O(ORX("ABHIS",I)) Q:I<1  D
    45         . . S X=ORX("ABHIS",I)
    46         . . I ABFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_$P(X,"^"),.CCNT) Q
    47         . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT),ABFND=1
    48         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    49         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    50         ;
    51         ; Transfusion Requirements section
    52         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Requirements",.CCNT)
    53         D LN
    54         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"------------------------",.CCNT) D
    55         . I '$O(ORX("TRREQ",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
    56         . D LN
    57         . S TREQFND=0
    58         . S I=0 F  S I=$O(ORX("TRREQ",I)) Q:I<1  D
    59         . . S X=ORX("TRREQ",I)
    60         . . I TREQFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_X,.CCNT) Q
    61         . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,X,.CCNT),TREQFND=1
    62         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    63         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    64         ;
    65         ; Transfusion Reactions section
    66         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Reactions",.CCNT)_$$S^ORU4(27,CCNT,"Date/Time",.CCNT)
    67         D LN
    68         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------",.CCNT) D
    69         . I '$O(ORX("TRHX",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
    70         . S I=0 F  S I=$O(ORX("TRHX",I)) Q:I<1  D
    71         . . D LN
    72         . . S X=ORX("TRHX",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",2)),.CCNT)
    73         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    74         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    75         ;
    76         ; New Units section
    77         N INDEX,UNT,ORY,I,CNT,J,K,L,M,X
    78         S CNT=0
    79         F INDEX="A","D","C","S" I $O(ORX("UNIT",INDEX,0)) D  ; A:Autologous D:Directed C:Crossmatched A:Assigned
    80         . S I=0 F  S I=$O(ORX("UNIT",INDEX,I)) Q:I<1  D
    81         .. S X=ORX("UNIT",INDEX,I),CNT=CNT+1,ORY("~"_$P(X,"^"),"~"_$P(X,"^",2),"~"_INDEX,"~"_$P(X,"^",4),CNT)=X
    82         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Units Available",.CCNT)
    83         D LN
    84         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------",.CCNT)
    85         D LN
    86         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Status",.CCNT)_$$S^ORU4(42,CCNT,"Exp Date",.CCNT)_$$S^ORU4(58,CCNT,"Division",.CCNT)
    87         D LN
    88         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"------",.CCNT)_$$S^ORU4(42,CCNT,"--------",.CCNT)_$$S^ORU4(58,CCNT,"--------",.CCNT)
    89         S I="" F  S I=$O(ORY(I)) Q:I=""  S J="" F  S J=$O(ORY(I,J)) Q:J=""  S K="" F  S K=$O(ORY(I,J,K)) Q:K=""  S L="" F  S L=$O(ORY(I,J,K,L)) Q:L=""  S M="" F  S M=$O(ORY(I,J,K,L,M)) Q:M=""  D LN D
    90         . S X=ORY(I,J,K,L,M),INDEX=$E(K,2),UNT=$S(INDEX="A":"Autologous",INDEX="D":"Directed",INDEX="C":"Crossmatched",INDEX="S":"Assigned",1:"Unknown")
    91         . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,UNT,.CCNT)_$$S^ORU4(42,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(58,CCNT,$P(X,"^",3),.CCNT)
    92         Q
    93 LN      ;Increment counts
    94         S GCNT=GCNT+1,CCNT=1
    95         Q
    96 DATETIME(X)     ; -- Return external form of YYYYMMDDHHNNSS date
    97         N Y S Y=$$HL7TFM^XLFDT(X),Y=$$DATETIME^ORCHTAB(Y)
    98         Q Y
     1ORWDXVB1 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04  09:31 ;12/7/05  17:20
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997
     3 ;
     4PTINFO ;Format patient BB info
     5 N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND
     6 S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80
     7 S OROOT=$NA(^TMP("ORVBEC",$J))
     8 K ^TMP("ORVBEC",$J)
     9 ;
     10 I +$G(ORX("ERROR")) D ERROR^ORWDXVB2 Q
     11 ; Patient Demographics
     12 D LN
     13 I '$D(ORX("PATIENT")) D  Q
     14 . D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     15 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(10,CCNT,"There is no previous record of this patient in VBECS.",.CCNT) Q
     16 ;
     17 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Name",.CCNT)_$$S^ORU4(27,CCNT,"SSN",.CCNT)_$$S^ORU4(42,CCNT,"ABO/Rh",.CCNT)
     18 D LN
     19 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----",.CCNT)_$$S^ORU4(27,CCNT,"---",.CCNT)_$$S^ORU4(42,CCNT,"------",.CCNT) D
     20 . D LN
     21 . S X=ORX("PATIENT"),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(X,"^",3)_", "_$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$P(X,"^",4),.CCNT)
     22 . I $P(ORX("ABORH"),"^")']"" S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,"unknown",.CCNT) Q
     23 . S X=ORX("ABORH"),^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,$$STRIP^XLFSTR($P(X,"^")," ")_" "_$S($$STRIP^XLFSTR($P(X,"^",2)," ")="P":"Pos",$$STRIP^XLFSTR($P(X,"^",2)," ")="N":"Neg",1:"unknown"),.CCNT) Q
     24 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     25 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     26 ;
     27 ; Available Specimens
     28 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Available Specimen UID",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date",.CCNT)
     29 D LN
     30 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------------",.CCNT) D
     31 . I '$D(ORX("SPECIMEN")) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
     32 . D LN
     33 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(ORX("SPECIMEN"),"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME^ORCHTAB($P(ORX("SPECIMEN"),"^")),.CCNT) Q
     34 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     35 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     36 ;
     37 ; Antibodies Identified section
     38 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Antibodies Identified",.CCNT)
     39 D LN
     40 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT) D
     41 . I '$O(ORX("ABHIS",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
     42 . D LN
     43 . S ABFND=0
     44 . S I=0 F  S I=$O(ORX("ABHIS",I)) Q:I<1  D
     45 . . S X=ORX("ABHIS",I)
     46 . . I ABFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_$P(X,"^"),.CCNT) Q
     47 . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT),ABFND=1
     48 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     49 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     50 ;
     51 ; Transfusion Requirements section
     52 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Requirements",.CCNT)
     53 D LN
     54 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"------------------------",.CCNT) D
     55 . I '$O(ORX("TRREQ",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
     56 . D LN
     57 . S TREQFND=0
     58 . S I=0 F  S I=$O(ORX("TRREQ",I)) Q:I<1  D
     59 . . S X=ORX("TRREQ",I)
     60 . . I TREQFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_X,.CCNT) Q
     61 . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,X,.CCNT),TREQFND=1
     62 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     63 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     64 ;
     65 ; Transfusion Reactions section
     66 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Reactions",.CCNT)_$$S^ORU4(27,CCNT,"Date/Time",.CCNT)
     67 D LN
     68 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------",.CCNT) D
     69 . I '$O(ORX("TRHX",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q
     70 . S I=0 F  S I=$O(ORX("TRHX",I)) Q:I<1  D
     71 . . D LN
     72 . . S X=ORX("TRHX",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",2)),.CCNT)
     73 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     74 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     75 ;
     76 ; Units section
     77 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Units Available",.CCNT)
     78 D LN
     79 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------",.CCNT)
     80 D LN
     81 ; Autologous Units
     82 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Autologous",.CCNT)
     83 D LN
     84 I $O(ORX("UNIT","A",0)) D
     85 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date  Division",.CCNT)
     86 . D LN
     87 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"---------------  --------",.CCNT) D
     88 . . S I=0 F  S I=$O(ORX("UNIT","A",I)) Q:I<1  D
     89 . . . D LN
     90 . . . S X=ORX("UNIT","A",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT)
     91 E  S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT)
     92 ;
     93 ; Directed Units
     94 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     95 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Directed",.CCNT)
     96 D LN
     97 I $O(ORX("UNIT","D",0)) D
     98 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date  Division",.CCNT)
     99 . D LN
     100 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"---------------  --------",.CCNT) D
     101 . . S I=0 F  S I=$O(ORX("UNIT","D",I)) Q:I<1  D
     102 . . . D LN
     103 . . . S X=ORX("UNIT","D",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT)
     104 E  S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT)
     105 ;
     106 ; Crossmatched Units
     107 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     108 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Crossmatched",.CCNT)
     109 D LN
     110 I $O(ORX("UNIT","C",0)) D
     111 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Available Until  Division",.CCNT)
     112 . D LN
     113 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"---------------  --------",.CCNT) D
     114 . . S I=0 F  S I=$O(ORX("UNIT","C",I)) Q:I<1  D
     115 . . . D LN
     116 . . . S X=ORX("UNIT","C",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT)
     117 E  S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT)
     118 ;
     119 ; Assigned Units
     120 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     121 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Assigned",.CCNT)
     122 D LN
     123 I $O(ORX("UNIT","S",0)) D
     124 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Available Until  Division",.CCNT)
     125 . D LN
     126 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"---------------  --------",.CCNT) D
     127 . . S I=0 F  S I=$O(ORX("UNIT","S",I)) Q:I<1  D
     128 . . . D LN
     129 . . . S X=ORX("UNIT","S",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT)
     130 E  S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT)
     131 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     132 ;
     133 Q
     134LN ;Increment counts
     135 S GCNT=GCNT+1,CCNT=1
     136 Q
     137DATETIME(X) ; -- Return external form of YYYYMMDDHHNNSS date
     138 N Y S Y=$$HL7TFM^XLFDT(X),Y=$$DATETIME^ORCHTAB(Y)
     139 Q Y

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB2.m

    r613 r623  
    1 ORWDXVB2        ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04  09:31
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242
    3         ;
    4 ERROR   ;Process error
    5         D LN
    6         S VBERROR=$P(ORX("ERROR"),"^",2)
    7         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN
    8         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    9         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                           WARNING!                             *",.CCNT) D LN
    10         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    11         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                An Error occurred attempting to                 *",.CCNT) D LN
    12         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                retrieve Blood Bank order data.                 *",.CCNT) D LN
    13         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    14         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*          This order cannot be completed at this time.          *",.CCNT) D LN
    15         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*         Revert to local downtime procedures to continue        *",.CCNT) D LN
    16         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*           order or retry this option at a later time.          *",.CCNT) D LN
    17         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    18         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*           Contact the Blood Bank System Administrator          *",.CCNT) D LN
    19         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    20         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN
    21         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    22         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                         Error Message                          *",.CCNT) D LN
    23         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    24         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT)
    25         I $L(VBERROR)<68 D
    26         . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(VBERROR)/2,CCNT,VBERROR,.CCNT)
    27         . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN
    28         I $L(VBERROR)>68 D
    29         . I $L(VBERROR)>136 S VBERROR=$E(VBERROR,1,136)_"..."
    30         . N L1 S L1=$E(VBERROR,1,$L(VBERROR)/2)
    31         . I $E(L1,$L(L1))'=" " D
    32         . . S LINE1=$E(L1,1,($L(L1)-($L($P(L1," ",$L(L1," ")))))),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR))
    33         . E  S LINE1=$E(L1),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR))
    34         . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE1)/2,CCNT,LINE1,.CCNT)
    35         . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN
    36         . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT)
    37         . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE2)/2,CCNT,LINE2,.CCNT)
    38         . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN
    39         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
    40         S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN
    41         D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
    42         Q
    43 PULL(OROOT,ORVP,ITEMID,SDATE,EDATE)     ;Get list of orders matching ITEM
    44         ;ITEM = Orderable Item ID e.g. "1;99VBC" for Type and Screen
    45         ;SDATE = Start Date for search
    46         ;EDATE = End Date for search
    47         Q:'$G(ORVP)
    48         N ORTNSB
    49         I $P(ORVP,";",2)="" S ORVP=ORVP_";DPT("
    50         S ORTNSB=$$GET^XPAR("ALL","ORWDXVB VBECS TNS CHECK",1,"I")
    51         S:'ORTNSB ORTNSB=3 ;Use Default of DT-3 or Parameter [ORWDXVB VBECS TNS CHECK] if no start date passed in
    52         S ITEMID=$S($D(ITEMID):ITEMID,1:"1;99VBC") ;Default to Type and Screen if nothing passed in
    53         S SDATE=$S($D(SDATE):SDATE,1:$$FMADD^XLFDT(DT-ORTNSB))
    54         S EDATE=$S($D(EDATE):EDATE,1:DT) ;Default to DT if no End date passed in
    55         N ORDG,FLG,ORLIST,ORX0,ORX3,ORSTAT,ORIFN,I,X,J,CNT,ITEM,ITEMNM,ORLOC,DIV
    56         S ITEM=+$O(^ORD(101.43,"ID",ITEMID,0)),ITEMNM=$P($G(^ORD(101.43,ITEM,0)),"^")
    57         S CNT=0,ORDG=$O(^ORD(100.98,"B","VBEC",0)) Q:'ORDG
    58         F FLG=4,23,19 D  ;Get completed, active/pending, unreleased
    59         . K ^TMP("ORR",$J)
    60         . D EN^ORQ1(ORVP,ORDG,FLG,0,SDATE,EDATE)
    61         . I '$O(^TMP("ORR",$J,ORLIST,0)) Q
    62         . S I=0
    63         . F  S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I  S X=^(I) D
    64         .. S ORIFN=+X,J=0,DIV=""
    65         .. Q:'$D(^OR(100,ORIFN,0))  S ORX0=^(0),ORX3=^(3)
    66         .. S ORSTAT=$S($D(^ORD(100.01,+$P(ORX3,"^",3),0)):$P(^(0),"^"),1:""),ORLOC=$S($L($P($G(^SC(+$P(ORX0,"^",10),0)),"^")):$P(^(0),"^"),1:"UNKNOWN")
    67         .. I +$P(ORX0,"^",10) S DIV=$P($G(^SC(+$P(ORX0,"^",10),0)),U,15),DIV=$S(DIV:$P($$SITE^VASITE(DT,DIV),"^",2),1:"")
    68         .. F  S J=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",J)) Q:'J  I +$G(^OR(100,ORIFN,4.5,J,1))=ITEM D
    69         ... S CNT=CNT+1,OROOT(CNT)="Duplicate order: "_ITEMNM_" entered "_$$FMTE^XLFDT($P(ORX0,"^",7))_" Div/Loc: "_DIV_":"_ORLOC_" ["_ORSTAT_"]"
    70         Q
    71 LN      ;Increment counts
    72         S GCNT=GCNT+1,CCNT=1
    73         Q
     1ORWDXVB2 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04  09:31
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997
     3 ;
     4ERROR ;Process error
     5 D LN
     6 S VBERROR=$P(ORX("ERROR"),"^",2)
     7 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN
     8 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     9 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                           WARNING!                             *",.CCNT) D LN
     10 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     11 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                An Error occurred attempting to                 *",.CCNT) D LN
     12 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                retrieve Blood Bank order data.                 *",.CCNT) D LN
     13 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     14 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*          This order cannot be completed at this time.          *",.CCNT) D LN
     15 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*         Revert to local downtime procedures to continue        *",.CCNT) D LN
     16 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*           order or retry this option at a later time.          *",.CCNT) D LN
     17 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     18 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*           Contact the Blood Bank System Administrator          *",.CCNT) D LN
     19 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     20 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN
     21 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     22 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                         Error Message                          *",.CCNT) D LN
     23 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     24 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT)
     25 I $L(VBERROR)<68 D
     26 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(VBERROR)/2,CCNT,VBERROR,.CCNT)
     27 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN
     28 I $L(VBERROR)>68 D
     29 . I $L(VBERROR)>136 S VBERROR=$E(VBERROR,1,136)_"..."
     30 . N L1 S L1=$E(VBERROR,1,$L(VBERROR)/2)
     31 . I $E(L1,$L(L1))'=" " D
     32 . . S LINE1=$E(L1,1,($L(L1)-($L($P(L1," ",$L(L1," ")))))),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR))
     33 . E  S LINE1=$E(L1),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR))
     34 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE1)/2,CCNT,LINE1,.CCNT)
     35 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN
     36 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT)
     37 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE2)/2,CCNT,LINE2,.CCNT)
     38 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN
     39 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*                                                                *",.CCNT) D LN
     40 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN
     41 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN
     42 Q
     43LN ;Increment counts
     44 S GCNT=GCNT+1,CCNT=1
     45 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI.m

    r613 r623  
    1 ORWGAPI ; SLC/STAFF - Graph API ;12/21/05  08:14
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4 ALLITEMS(ITEMS,DFN)     ; API - return all items of data on patient (procedures, tests, codes,..)
    5         N CNT,SUB,TMP,TYPE
    6         K ^TMP("ORWGAPI",$J)
    7         S DFN=+$G(DFN) I 'DFN Q
    8         D TYPES("ORWGAPI",DFN)
    9         D RETURN^ORWGAPIW(.TMP,.ITEMS)
    10         S CNT=0
    11         S SUB=""
    12         F  S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB=""  D
    13         . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U)
    14         . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,0,,,.CNT,TMP)
    15         D SETLAST^ORWGTASK(DFN)
    16         K ^TMP("ORWGAPI",$J)
    17         Q
    18         ;
    19 ALLVIEWS(DATA,VIEW,USER)        ; API - get all graph views
    20         D ALLVIEWS^ORWGAPIP(.DATA,+$G(VIEW),+$G(USER))
    21         Q
    22         ;
    23 CLASS(DATA,TYPE)        ; API - get classification
    24         I TYPE=50.605 D DRUGC^ORWGAPIC(.DATA)
    25         I TYPE=68 D ACC^ORWGAPIC(.DATA)
    26         I TYPE=8925.1 D TIUTITLE^ORWGAPIA(.DATA)
    27         I TYPE=100.98 D OITEM^ORWGAPIA(.DATA)
    28         Q
    29         ;
    30 DATEDATA(DATA,OLDEST,NEWEST,TYPEITEM,DFN)       ; API - return all data for an item on patient for date range
    31         N CNT,ITEM,SUB,TMP,TYPE
    32         S DFN=+$G(DFN) I 'DFN Q
    33         S OLDEST=+$G(OLDEST)
    34         S NEWEST=+$G(NEWEST,$$NOW^ORWGAPIX)
    35         S TYPEITEM=$G(TYPEITEM) I TYPEITEM'[U Q
    36         I 'OLDEST D ITEMDATA(.DATA,TYPEITEM,NEWEST,DFN,OLDEST) Q
    37         I OLDEST<NEWEST Q
    38         S TYPEITEM=$$UP^ORWGAPIX(TYPEITEM)
    39         D RETURN^ORWGAPIW(.TMP,.DATA)
    40         S TYPE=$P(TYPEITEM,U)
    41         S ITEM=$P(TYPEITEM,U,2)
    42         S CNT=0
    43         D DATA^ORWGAPIR(.DATA,ITEM,TYPE,NEWEST,DFN,.CNT,TMP,OLDEST)
    44         Q
    45         ;
    46 DATEITEM(ITEMS,OLDEST,NEWEST,TYPE,DFN)  ; API - return all file items on patient for date range
    47         N CNT,SUB,TMP
    48         K ^TMP("ORWGAPI",$J)
    49         S DFN=+$G(DFN) I 'DFN Q
    50         S OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),TYPE=$G(TYPE)
    51         I $L(TYPE) S ^TMP("ORWGAPI",$J,1)=TYPE
    52         I '$L(TYPE) D TYPES("ORWGAPI",DFN)
    53         D RETURN^ORWGAPIW(.TMP,.ITEMS)
    54         S CNT=0
    55         S SUB=""
    56         F  S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB=""  D
    57         . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U)
    58         . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,6,OLDEST,NEWEST,.CNT,TMP)
    59         K ^TMP("ORWGAPI",$J)
    60         Q
    61         ;
    62 DELVIEWS(DATA,NAME,PUBLIC)      ; API - delete a graph view
    63         D DELVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC))
    64         Q
    65         ;
    66 DETAIL(DATA,DFN,DATE1,DATE2,VAL,COMP)   ; API - get all reports for types of data from items and date range
    67         D DETAIL^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,.VAL)
    68         S DATA=$NA(^TMP("ORWGRPC",$J))
    69         Q
    70         ;
    71 DETAILS(DATA,DFN,DATE1,DATE2,TYPE,COMP) ; API - get report for type of data for a date or date range
    72         D DETAILS^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,TYPE)
    73         S DATA=$NA(^TMP("ORWGRPC",$J))
    74         Q
    75         ;
    76 FASTDATA(DATA,DFN)      ; API - get all data (non-lab) on patient
    77         D FASTDATA^ORWGAPIF(.DATA,DFN)
    78         Q
    79         ;
    80 FASTITEM(ITEMS,DFN)     ; API - get all items on patient
    81         D FASTITEM^ORWGAPIF(.ITEMS,DFN)
    82         D SETLAST^ORWGTASK(DFN)
    83         Q
    84         ;
    85 FASTLABS(DATA,DFN)      ; API - get all lab data on patient
    86         D FASTLABS^ORWGAPIF(.DATA,DFN)
    87         Q
    88         ;
    89 FASTTASK(STATUS,DFN,OLDDFN)     ; API - process cache of all data and items on patient, -1 if turned off
    90         ; this should be able to be turned off if needbe (D CLEAN^ORWGTASK)
    91         D UPDATE^ORWGTASK(.STATUS,DFN,DUZ,+$G(OLDDFN))
    92         Q
    93         ;
    94 GETDATES(DATA,REPORTID) ; API - get graph date ranges
    95         D GETDATES^ORWGAPID(.DATA,$G(REPORTID))
    96         Q
    97         ;
    98 GETPREF(DATA)   ; API - get graph settings
    99         D GETPREF^ORWGAPIP(.DATA)
    100         Q
    101         ;
    102 GETSIZE(DATA)   ; API - get graph positions and sizes
    103         D GETSIZE^ORWGAPIP(.DATA)
    104         Q
    105         ;
    106 GETVIEWS(DATA,ALL,PUBLIC,EXT,USER)      ; API - get graph views
    107         D GETVIEWS^ORWGAPIP(.DATA,$G(ALL),$G(PUBLIC),$G(EXT),+$G(USER))
    108         Q
    109         ;
    110 ITEMDATA(DATA,TYPEITEM,START,DFN,BACKTO)        ; API - return data of an item on patient (glucose results)
    111         N CNT,ITEM,TMP,TYPE
    112         S DFN=+$G(DFN) I 'DFN Q
    113         S TYPEITEM=$G(TYPEITEM) I TYPEITEM'[U Q
    114         S TYPEITEM=$$UP^ORWGAPIX(TYPEITEM)
    115         S START=$G(START,$$NOW^ORWGAPIX)
    116         D RETURN^ORWGAPIW(.TMP,.DATA)
    117         S TYPE=$P(TYPEITEM,U)
    118         S ITEM=$P(TYPEITEM,U,2)
    119         S CNT=0
    120         D DATA^ORWGAPIR(.DATA,ITEM,TYPE,START,DFN,.CNT,TMP,$G(BACKTO))
    121         Q
    122         ;
    123 ITEMS(ITEMS,DFN,TYPE)   ; API - return items of a type of data on patient (lab tests)
    124         N CNT,TMP
    125         S DFN=+$G(DFN) I 'DFN Q
    126         S TYPE=$G(TYPE) I '$L(TYPE) Q
    127         D RETURN^ORWGAPIW(.TMP,.ITEMS)
    128         S CNT=0
    129         D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,3,,,.CNT,TMP)
    130         I TYPE=63 D SETLAST^ORWGTASK(DFN)
    131         Q
    132         ;
    133 LOOKUP(VAL,FILE,FROM,DIR)       ; API - get item names for long lookup
    134         N REF,SCREEN,XREF
    135         D FILE^ORWGAPIU($G(FILE),.REF,.XREF,.SCREEN)
    136         I '$L(REF) Q
    137         D GENERIC^ORWGAPIW(.VAL,.FROM,DIR,FILE,REF,XREF,SCREEN)
    138         Q
    139         ;
    140 PUBLIC(USER)    ; API - $$(user) -> 1 if user can edit public settings and views
    141         Q $$PUBLIC^ORWGAPIP(USER)
    142         ;
    143 RPTPARAM(IEN)   ; API - $$(ien) -> PARAM1^PARAM2 for graph report else ""
    144         Q $$RPTPARAM^ORWGAPIP(IEN)
    145         ;
    146 SETPREF(DATA,VAL,PUBLIC)        ; API - set a graph setting
    147         D SETPREF^ORWGAPIP(.DATA,$G(VAL),$G(PUBLIC))
    148         Q
    149         ;
    150 SETSIZE(DATA,VAL)       ; API - set graph positions and settings
    151         D SETSIZE^ORWGAPIP(.DATA,.VAL)
    152         Q
    153         ;
    154 SETVIEWS(DATA,NAME,PUBLIC,VAL)  ; API - set a graph view
    155         D SETVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC),.VAL)
    156         Q
    157         ;
    158 TAX(DATA,ALL,REMTAX)    ; API - get reminder taxonomies
    159         D TAX^ORWGAPID(.DATA,+$G(ALL),.REMTAX)
    160         Q
    161         ;
    162 TESTING(DATA)   ; API - return test data
    163         D TESTING^ORWGTEST(.DATA)
    164         Q
    165         ;
    166 TESTSPEC(DATA)  ;  API - return test/spec info on all lab tests
    167         D TESTSPEC^ORWGAPIC(.DATA)
    168         Q
    169         ;
    170 TYPES(TYPES,DFN,SUB)    ; API - return all types of data on patient (if no dfn, return all)
    171         N TMP
    172         S DFN=+$G(DFN)
    173         S SUB=+$G(SUB)
    174         D RETURN^ORWGAPIW(.TMP,.TYPES)
    175         D TYPES^ORWGAPIT(.TYPES,DFN,SUB,TMP)
    176         Q
     1ORWGAPI ; SLC/STAFF - Graph API ;12/21/05  08:14
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4ALLITEMS(ITEMS,DFN) ; API - return all items of data on patient (procedures, tests, codes,..)
     5 N CNT,SUB,TMP,TYPE
     6 K ^TMP("ORWGAPI",$J)
     7 S DFN=+$G(DFN) I 'DFN Q
     8 D TYPES("ORWGAPI",DFN)
     9 D RETURN^ORWGAPIU(.TMP,.ITEMS)
     10 S CNT=0
     11 S SUB=""
     12 F  S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB=""  D
     13 . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U)
     14 . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,0,,,.CNT,TMP)
     15 K ^TMP("ORWGAPI",$J)
     16 Q
     17 ;
     18CLASS(DATA,TYPE) ; API - get classification
     19 I TYPE=50.605 D DRUGC^ORWGAPIA(.DATA)
     20 I TYPE=68 D ACC^ORWGAPIA(.DATA)
     21 I TYPE=8925.1 D TIUTITLE^ORWGAPIA(.DATA)
     22 I TYPE=100.98 D OITEM^ORWGAPIA(.DATA)
     23 Q
     24 ;
     25DATEITEM(ITEMS,OLDEST,NEWEST,TYPE,DFN) ; API - return all file items on patient for date range
     26 N CNT,SUB,TMP
     27 K ^TMP("ORWGAPI",$J)
     28 S DFN=+$G(DFN) I 'DFN Q
     29 S OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),TYPE=$G(TYPE)
     30 I $L(TYPE) S ^TMP("ORWGAPI",$J,1)=TYPE
     31 I '$L(TYPE) D TYPES("ORWGAPI",DFN)
     32 D RETURN^ORWGAPIU(.TMP,.ITEMS)
     33 S CNT=0
     34 S SUB=""
     35 F  S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB=""  D
     36 . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U)
     37 . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,6,OLDEST,NEWEST,.CNT,TMP)
     38 K ^TMP("ORWGAPI",$J)
     39 Q
     40 ;
     41DELVIEWS(DATA,NAME,PUBLIC) ; API - delete a graph view
     42 D DELVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC))
     43 Q
     44 ;
     45DETAIL(DATA,DFN,DATE1,DATE2,VAL,COMP) ; API - get all reports for types of data from items and date range
     46 D DETAIL^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,.VAL)
     47 S DATA=$NA(^TMP("ORWGRPC",$J))
     48 Q
     49 ;
     50DETAILS(DATA,DFN,DATE1,DATE2,TYPE,COMP) ; API - get report for type of data for a date or date range
     51 D DETAILS^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,TYPE)
     52 S DATA=$NA(^TMP("ORWGRPC",$J))
     53 Q
     54 ;
     55GETDATES(DATA,REPORTID) ; API - get graph date ranges
     56 N DAT,TMP K DAT
     57 S REPORTID=$G(REPORTID)
     58 D RETURN^ORWGAPIU(.TMP,.DATA)
     59 S DAT(1)="S^Date Range..."
     60 S DAT(2)="1^Today"
     61 S DAT(3)="2^One Week"
     62 S DAT(4)="3^Two Weeks"
     63 S DAT(5)="4^One Month"
     64 S DAT(6)="5^Six Months"
     65 S DAT(7)="6^One Year"
     66 S DAT(8)="7^Two Years"
     67 S DAT(9)="8^All Results"
     68 D DATES^ORWGAPIP(.DAT,REPORTID)
     69 I TMP M ^TMP(DATA,$J)=DAT
     70 I 'TMP M DATA=DAT
     71 Q
     72 ;
     73GETPREF(DATA) ; API - get graph settings
     74 D GETPREF^ORWGAPIP(.DATA)
     75 Q
     76 ;
     77GETSIZE(DATA) ; API - get graph positions and sizes
     78 D GETSIZE^ORWGAPIP(.DATA)
     79 Q
     80 ;
     81GETVIEWS(DATA,ALL,PUBLIC,EXT) ; API - get graph views
     82 D GETVIEWS^ORWGAPIP(.DATA,$G(ALL),$G(PUBLIC),$G(EXT))
     83 Q
     84 ;
     85ITEMDATA(DATA,ITEM,START,DFN) ; API - return data of an item on patient (glucose results)
     86 N CNT,FILE,TMP
     87 S DFN=+$G(DFN) I 'DFN Q
     88 S ITEM=$G(ITEM) I ITEM'[U Q
     89 S START=$G(START,$$NOW^ORWGAPIX)
     90 D RETURN^ORWGAPIU(.TMP,.DATA)
     91 S FILE=$P(ITEM,U)
     92 S ITEM=$P(ITEM,U,2)
     93 S CNT=0
     94 D DATA^ORWGAPIR(.DATA,ITEM,FILE,START,DFN,.CNT,TMP)
     95 Q
     96 ;
     97ITEMS(ITEMS,DFN,TYPE) ; API - return items of a type of data on patient (lab tests)
     98 N CNT,TMP
     99 S DFN=+$G(DFN) I 'DFN Q
     100 S TYPE=$G(TYPE) I '$L(TYPE) Q
     101 D RETURN^ORWGAPIU(.TMP,.ITEMS)
     102 S CNT=0
     103 D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,3,,,.CNT,TMP)
     104 Q
     105 ;
     106LOOKUP(VAL,FILE,FROM,DIR) ; API - get item names for long lookup
     107 N REF,SCREEN,XREF
     108 D FILE^ORWGAPIU($G(FILE),.REF,.XREF,.SCREEN)
     109 I '$L(REF) Q
     110 D GENERIC^ORWGAPIU(.VAL,.FROM,DIR,FILE,REF,XREF,SCREEN)
     111 Q
     112 ;
     113PUBLIC(USER) ; API - $$(user) -> 1 if user can edit public settings and views
     114 Q $$PUBLIC^ORWGAPIP(USER)
     115 ;
     116RPTPARAM(IEN) ; API - $$(ien) -> PARAM1^PARAM2 for graph report else ""
     117 Q $$RPTPARAM^ORWGAPIP(IEN)
     118 ;
     119SETPREF(DATA,VAL,PUBLIC) ; API - set a graph setting
     120 D SETPREF^ORWGAPIP(.DATA,$G(VAL),$G(PUBLIC))
     121 Q
     122 ;
     123SETSIZE(DATA,VAL) ; API - set graph positions and settings
     124 D SETSIZE^ORWGAPIP(.DATA,.VAL)
     125 Q
     126 ;
     127SETVIEWS(DATA,NAME,PUBLIC,VAL) ; API - set a graph view
     128 D SETVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC),.VAL)
     129 Q
     130 ;
     131TAX(DATA,ALL,REMTAX) ; API - get reminder taxonomies
     132 D TAX^ORWGAPID(.DATA,+$G(ALL),.REMTAX)
     133 Q
     134 ;
     135TESTSPEC(DATA) ;  API - return test/spec info on all lab tests
     136 N CNT,LINE,TEST,TMP,SPEC
     137 D RETURN^ORWGAPIU(.TMP,.DATA)
     138 S CNT=0
     139 S TEST=0
     140 F  S TEST=$O(^LAB(60,TEST)) Q:TEST<1  D
     141 . S SPEC=0
     142 . F  S SPEC=$O(^LAB(60,TEST,1,SPEC)) Q:SPEC<1  D
     143 .. S CNT=CNT+1
     144 .. S LINE=TEST_U_$G(^LAB(60,TEST,1,SPEC,0))
     145 .. I $P(LINE,U,3)[$C(34) S $P(LINE,U,3)=$$TRIM^ORWGAPIX($P(LINE,U,3),"LR",$C(34))
     146 .. I $P(LINE,U,4)[$C(34) S $P(LINE,U,4)=$$TRIM^ORWGAPIX($P(LINE,U,4),"LR",$C(34))
     147 .. I TMP S ^TMP(DATA,$J,CNT)=LINE Q
     148 .. S DATA(CNT)=LINE
     149 Q
     150 ;
     151TYPES(TYPES,DFN,SUB) ; API - return all types of data on patient (if no dfn, return all)
     152 N TMP
     153 S DFN=+$G(DFN)
     154 S SUB=+$G(SUB)
     155 D RETURN^ORWGAPIU(.TMP,.TYPES)
     156 D TYPES^ORWGAPIT(.TYPES,DFN,SUB,TMP)
     157 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI1.m

    r613 r623  
    1 ORWGAPI1        ; SLC/STAFF - Graph Items ;12/21/05  08:15
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4 AA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
    5         ; FMT,OLDEST,NEWEST not used
    6         N ITEM,FILE,NUM,REF,RESULT
    7         K ^TMP("ORWGRPC DC",$J)
    8         S ITEM=""
    9         F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  D
    10         . I $E(ITEM)="A" Q
    11         . I $E(ITEM)="M" Q
    12         . S RESULT=$$AALAB^ORWGAPIC(ITEM)
    13         . I RESULT="" Q
    14         . S RESULT="68^"_RESULT
    15         . S ^TMP("ORWGRPC DC",$J,RESULT)=""
    16         S RESULT=""
    17         F  S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT=""  S CNT=CNT+1 D
    18         . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    19         K ^TMP("ORWGRPC DC",$J)
    20         Q
    21         ;
    22 AP(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
    23         N DATE,ITEM,OK,RESULT
    24         S ITEM="A"
    25         F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  Q:ITEM]"AZ"  D
    26         . S OK=0
    27         . I FMT=6 D
    28         .. S DATE=OLDEST
    29         .. F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    30         ... S CNT=CNT+1
    31         ... S OK=1
    32         ... S RESULT="63AP"_U_ITEM
    33         . I FMT=3 D
    34         .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1)
    35         .. I 'DATE Q
    36         .. S OK=1
    37         .. S CNT=CNT+1
    38         .. S RESULT="63AP^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE
    39         . I FMT=0 D
    40         .. S OK=1
    41         .. S CNT=CNT+1
    42         .. S RESULT="63AP^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)
    43         . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    44         Q
    45         ;
    46 LAB(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)        ; from ORWGAPIR
    47         N DATE,ITEM,OK,RESULT
    48         S ITEM=0
    49         F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM<1  D
    50         . S OK=0
    51         . I FMT=6 D
    52         .. S DATE=OLDEST
    53         .. F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    54         ... S CNT=CNT+1
    55         ... S OK=1
    56         ... S RESULT=63_U_ITEM
    57         . I FMT=3 D
    58         .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1)
    59         .. I 'DATE Q
    60         .. S CNT=CNT+1
    61         .. S OK=1
    62         .. S RESULT=63_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE
    63         . I FMT=0 D
    64         .. S CNT=CNT+1
    65         .. S OK=1
    66         .. S RESULT=63_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,63,.01)
    67         . I OK D
    68         .. S RESULT=RESULT_U_$$AALAB^ORWGAPIC(ITEM)
    69         .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    70         Q
    71         ;
    72 MI(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
    73         N DATE,ITEM,OK,RESULT
    74         S ITEM="M"
    75         F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  Q:ITEM]"MZ"  D
    76         . S OK=0
    77         . I FMT=6 D
    78         .. S DATE=OLDEST
    79         .. F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    80         ... S CNT=CNT+1
    81         ... S OK=1
    82         ... S RESULT="63MI"_U_ITEM
    83         . I FMT=3 D
    84         .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1)
    85         .. I 'DATE Q
    86         .. S CNT=CNT+1
    87         .. S OK=1
    88         .. S RESULT="63MI^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE
    89         . I FMT=0 D
    90         .. S CNT=CNT+1
    91         .. S OK=1
    92         .. S RESULT="63MI^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)
    93         . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    94         Q
    95         ;
    96 MED(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)        ; from ORWGAPIR
    97         D MED1^ORWGAPIE(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP)
    98         Q
    99         ;
    100 NOTES(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)      ; from ORWGAPIR
    101         N DATE,DOC,DOCCLASS,DOCIEN,DOCTYPE,DUMMY,RESULT,RESULTS,TITLE K DUMMY
    102         K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
    103         S CNT=$G(CNT)
    104         I FMT=6 D
    105         . F DOCTYPE="P","D","C" D
    106         .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
    107         .. K ^TMP("TIUR",$J)
    108         .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN,$G(OLDEST),$G(NEWEST))
    109         .. S DOC=0
    110         .. F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
    111         ... S RESULTS=^TMP("TIUR",$J,DOC)
    112         ... S TITLE=$P(RESULTS,U,2)
    113         ... S DATE=$P(RESULTS,U,3)
    114         ... I '$L(TITLE) Q
    115         ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS
    116         I FMT'=6 D
    117         . F DOCTYPE="P","D","C" D
    118         .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
    119         .. K ^TMP("TIUR",$J)
    120         .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN)
    121         .. S DOC=0
    122         .. F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
    123         ... S RESULTS=^TMP("TIUR",$J,DOC)
    124         ... S TITLE=$P(RESULTS,U,2)
    125         ... S DATE=$P(RESULTS,U,3)
    126         ... I '$L(TITLE) Q
    127         ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS
    128         S TITLE=""
    129         F  S TITLE=$O(^TMP("ORWGRPC TEMP",$J,TITLE)) Q:TITLE=""  D
    130         . S CNT=CNT+1
    131         . I FMT=6 S RESULT=8925_U_TITLE
    132         . I FMT=3 D
    133         .. S DATE=+$O(^TMP("ORWGRPC TEMP",$J,TITLE,""),-1)
    134         .. S DOCIEN=+$G(^TMP("ORWGRPC TEMP",$J,TITLE,DATE))
    135         .. S RESULT=8925_U_TITLE_"^^"_TITLE_"^^"
    136         .. S RESULT=RESULT_DATE
    137         .. S RESULT=RESULT_U_$$TITLE^ORWGAPIA(DOCIEN)
    138         . I FMT=0 S RESULT=8925_U_TITLE_U_TITLE
    139         . S RESULT=$$UP^ORWGAPIX(RESULT)
    140         . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    141         K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
    142         Q
    143         ;
    144 TITLE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)      ; from ORWGAPIR
    145         ; FMT,OLDEST,NEWEST not used
    146         N ITEM,FILE,NUM,REF,RESULT
    147         K ^TMP("ORWGRPC DC",$J)
    148         S ITEM=""
    149         F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  D
    150         . I $E(ITEM)="A" Q
    151         . I $E(ITEM)="M" Q
    152         . S RESULT=$$AALAB^ORWGAPIC(ITEM)
    153         . I RESULT="" Q
    154         . S RESULT="68^"_RESULT
    155         . S ^TMP("ORWGRPC DC",$J,RESULT)=""
    156         S RESULT=""
    157         F  S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT=""  S CNT=CNT+1 D
    158         . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    159         K ^TMP("ORWGRPC DC",$J)
    160         Q
    161         ;
     1ORWGAPI1 ; SLC/STAFF - Graph Items ;12/21/05  08:15
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4AA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     5 ; FMT,OLDEST,NEWEST not used
     6 N ITEM,FILE,NUM,REF,RESULT
     7 K ^TMP("ORWGRPC DC",$J)
     8 S ITEM=""
     9 F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  D
     10 . I $E(ITEM)="A" Q
     11 . I $E(ITEM)="M" Q
     12 . S RESULT=$$AALAB^ORWGAPIA(ITEM)
     13 . I RESULT="" Q
     14 . S RESULT="68^"_RESULT
     15 . S ^TMP("ORWGRPC DC",$J,RESULT)=""
     16 S RESULT=""
     17 F  S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT=""  S CNT=CNT+1 D
     18 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     19 K ^TMP("ORWGRPC DC",$J)
     20 Q
     21 ;
     22AP(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     23 N DATE,ITEM,OK,RESULT
     24 S ITEM="A"
     25 F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  Q:ITEM]"AZ"  D
     26 . S OK=0
     27 . I FMT=6 D
     28 .. S DATE=OLDEST
     29 .. F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     30 ... S CNT=CNT+1
     31 ... S OK=1
     32 ... S RESULT="63AP"_U_ITEM
     33 . I FMT=3 D
     34 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1)
     35 .. I 'DATE Q
     36 .. S OK=1
     37 .. S CNT=CNT+1
     38 .. S RESULT="63AP^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE
     39 . I FMT=0 D
     40 .. S OK=1
     41 .. S CNT=CNT+1
     42 .. S RESULT="63AP^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)
     43 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     44 Q
     45 ;
     46BCMA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     47 N DATE,DRUG,ITEM,NUM,RESULT
     48 K ^TMP("ORWGRPC TEMP",$J)
     49 I FMT=6 D
     50 . S DATE=OLDEST
     51 . F  S DATE=$O(^PSB(53.79,"AADT",DFN,DATE)) Q:DATE<1  Q:DATE>NEWEST  D
     52 .. S NUM=0
     53 .. F  S NUM=$O(^PSB(53.79,"AADT",DFN,DATE,NUM)) Q:NUM<1  D
     54 ... S ITEM=$P($G(^PSB(53.79,NUM,0)),U,8) I 'ITEM Q
     55 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
     56 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     57 ... S CNT=CNT+1
     58 ... S RESULT="53.79^"_ITEM
     59 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     60 I FMT'=6 D
     61 . S ITEM=""
     62 . F  S ITEM=$O(^PSB(53.79,"AOIP",DFN,ITEM)) Q:ITEM=""  D
     63 .. S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,""),-1)
     64 .. I 'DATE Q
     65 .. S NUM=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,""),-1)
     66 .. I 'NUM Q
     67 .. S CNT=CNT+1
     68 .. I FMT=3 S RESULT="53.79^"_ITEM_"^^"_$$POINAME^ORWGAPIA(ITEM)_"^^"_DATE
     69 .. I FMT=0 S RESULT="53.79^"_ITEM_U_$$POINAME^ORWGAPIA(ITEM)
     70 .. S DRUG=$$DRUG^ORWGAPIA(NUM)
     71 .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG)
     72 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     73 K ^TMP("ORWGRPC TEMP",$J)
     74 Q
     75 ;
     76DC(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     77 ; FMT,OLDEST,NEWEST not used
     78 N DATA,DATE,DATE1,DRUG,ITEM,FILE,NUM,REF,RESULT K DATA
     79 K ^TMP("ORWGRPC DC",$J)
     80 F FILE=52,55 D
     81 . S ITEM=""
     82 . F  S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM=""  D
     83 .. S RESULT=$$DRGCLASS^ORWGAPIA(ITEM)
     84 .. I RESULT="" Q
     85 .. S RESULT="50.605^"_RESULT
     86 .. S ^TMP("ORWGRPC DC",$J,RESULT)=""
     87 S ITEM=""
     88 F  S ITEM=$O(^PSB(53.79,"AOIP",DFN,ITEM)) Q:ITEM=""  D
     89 . S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,""),-1)
     90 . I 'DATE Q
     91 . S NUM=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,""),-1)
     92 . I 'NUM Q
     93 . S DRUG=$$DRUG^ORWGAPIA(NUM)
     94 . I 'DRUG Q
     95 . S RESULT=$$DRGCLASS^ORWGAPIA(DRUG)
     96 . I 'RESULT Q
     97 . S RESULT="50.605^"_RESULT
     98 . S ^TMP("ORWGRPC DC",$J,RESULT)=""
     99 S ITEM=""
     100 F  S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM=""  D
     101 . S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1)
     102 . I 'DATE Q
     103 . S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1)
     104 . I '$L(DATE1) Q
     105 . S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1)
     106 . I '$L(REF) Q
     107 . D RXNVA^ORWGAPIA(REF,.DATA)
     108 . S DRUG=+$G(DATA("DISPENSE DRUG"))
     109 . I 'DRUG Q
     110 . S RESULT=$$DRGCLASS^ORWGAPIA(DRUG)
     111 . I 'RESULT Q
     112 . S RESULT="50.605^"_RESULT
     113 . S ^TMP("ORWGRPC DC",$J,RESULT)=""
     114 S RESULT=""
     115 F  S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT=""  S CNT=CNT+1 D
     116 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     117 K ^TMP("ORWGRPC DC",$J)
     118 Q
     119 ;
     120LAB(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     121 N DATE,ITEM,OK,RESULT
     122 S ITEM=0
     123 F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM<1  D
     124 . S OK=0
     125 . I FMT=6 D
     126 .. S DATE=OLDEST
     127 .. F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     128 ... S CNT=CNT+1
     129 ... S OK=1
     130 ... S RESULT=63_U_ITEM
     131 . I FMT=3 D
     132 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1)
     133 .. I 'DATE Q
     134 .. S CNT=CNT+1
     135 .. S OK=1
     136 .. S RESULT=63_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE
     137 . I FMT=0 D
     138 .. S CNT=CNT+1
     139 .. S OK=1
     140 .. S RESULT=63_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,63,.01)
     141 . I OK D
     142 .. S RESULT=RESULT_U_$$AALAB^ORWGAPIA(ITEM)
     143 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     144 Q
     145 ;
     146MI(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     147 N DATE,ITEM,OK,RESULT
     148 S ITEM="M"
     149 F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  Q:ITEM]"MZ"  D
     150 . S OK=0
     151 . I FMT=6 D
     152 .. S DATE=OLDEST
     153 .. F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     154 ... S CNT=CNT+1
     155 ... S OK=1
     156 ... S RESULT="63MI"_U_ITEM
     157 . I FMT=3 D
     158 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1)
     159 .. I 'DATE Q
     160 .. S CNT=CNT+1
     161 .. S OK=1
     162 .. S RESULT="63MI^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE
     163 . I FMT=0 D
     164 .. S CNT=CNT+1
     165 .. S OK=1
     166 .. S RESULT="63MI^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)
     167 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     168 Q
     169 ;
     170MED(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     171 D MED1^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP)
     172 Q
     173 ;
     174NOTES(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     175 N DATE,DOC,DOCCLASS,DOCIEN,DOCTYPE,DUMMY,RESULT,RESULTS,TITLE K DUMMY
     176 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
     177 S CNT=$G(CNT)
     178 I FMT=6 D
     179 . F DOCTYPE="P","D","C" D
     180 .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
     181 .. K ^TMP("TIUR",$J)
     182 .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN,$G(OLDEST),$G(NEWEST))
     183 .. S DOC=0
     184 .. F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
     185 ... S RESULTS=^TMP("TIUR",$J,DOC)
     186 ... S TITLE=$P(RESULTS,U,2)
     187 ... S DATE=$P(RESULTS,U,3)
     188 ... I '$L(TITLE) Q
     189 ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS
     190 I FMT'=6 D
     191 . F DOCTYPE="P","D","C" D
     192 .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
     193 .. K ^TMP("TIUR",$J)
     194 .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN)
     195 .. S DOC=0
     196 .. F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
     197 ... S RESULTS=^TMP("TIUR",$J,DOC)
     198 ... S TITLE=$P(RESULTS,U,2)
     199 ... S DATE=$P(RESULTS,U,3)
     200 ... I '$L(TITLE) Q
     201 ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS
     202 S TITLE=""
     203 F  S TITLE=$O(^TMP("ORWGRPC TEMP",$J,TITLE)) Q:TITLE=""  D
     204 . S CNT=CNT+1
     205 . I FMT=6 S RESULT=8925_U_TITLE
     206 . I FMT=3 D
     207 .. S DATE=+$O(^TMP("ORWGRPC TEMP",$J,TITLE,""),-1)
     208 .. S DOCIEN=+$G(^TMP("ORWGRPC TEMP",$J,TITLE,DATE))
     209 .. S RESULT=8925_U_TITLE_"^^"_TITLE_"^^"
     210 .. S RESULT=RESULT_DATE
     211 .. S RESULT=RESULT_U_$$TITLE^ORWGAPIA(DOCIEN)
     212 . I FMT=0 S RESULT=8925_U_TITLE_U_TITLE
     213 . S RESULT=$$UP^ORWGAPIX(RESULT)
     214 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     215 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
     216 Q
     217 ;
     218NVAE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     219 N DATA,DATE,DATE1,DRUG,ITEM,OK,REF,RESULT K DATA
     220 S ITEM=""
     221 F  S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM=""  D
     222 . S OK=0
     223 . I FMT=6 D
     224 .. S DATE=OLDEST
     225 .. F  S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     226 ... S CNT=CNT+1
     227 ... S OK=1
     228 ... S RESULT="55NVAE"_U_ITEM
     229 . I FMT'=6 D
     230 .. S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1)
     231 .. I 'DATE Q
     232 .. S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1)
     233 .. I '$L(DATE1) Q
     234 .. S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1)
     235 .. I '$L(REF) Q
     236 .. D RXNVA^ORWGAPIA(REF,.DATA)
     237 .. S DRUG=+$G(DATA("DISPENSE DRUG"))
     238 .. S CNT=CNT+1
     239 .. S OK=1
     240 .. I FMT=3 S RESULT="55NVAE"_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)_"^^"_DATE
     241 .. I FMT=0 S RESULT="55NVAE"_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)
     242 .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG)
     243 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     244 Q
     245 ;
     246NVA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     247 D NVA1^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP)
     248 Q
     249 ;
     250TITLE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     251 ; FMT,OLDEST,NEWEST not used
     252 N ITEM,FILE,NUM,REF,RESULT
     253 K ^TMP("ORWGRPC DC",$J)
     254 S ITEM=""
     255 F  S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM=""  D
     256 . I $E(ITEM)="A" Q
     257 . I $E(ITEM)="M" Q
     258 . S RESULT=$$AALAB^ORWGAPIA(ITEM)
     259 . I RESULT="" Q
     260 . S RESULT="68^"_RESULT
     261 . S ^TMP("ORWGRPC DC",$J,RESULT)=""
     262 S RESULT=""
     263 F  S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT=""  S CNT=CNT+1 D
     264 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     265 K ^TMP("ORWGRPC DC",$J)
     266 Q
     267 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI2.m

    r613 r623  
    1 ORWGAPI2        ; SLC/STAFF - Graph API Items ;12/21/05  08:16
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4 ADVERSE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)    ; from ORWGAPIR
    5         N DATE,IEN,ITEM,RESULT
    6         K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J)
    7         S IEN=0
    8         F  S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN<1  D
    9         . I '$D(^GMR(120.8,IEN,0)) Q
    10         . I $G(^GMR(120.8,IEN,"ER")) Q
    11         . I '$P(^GMR(120.8,IEN,0),U,12) Q
    12         . S DATE=+$P($G(^GMR(120.8,IEN,0)),U,4) I 'DATE Q
    13         . S ITEM=$P(^GMR(120.8,IEN,0),U,2) I '$L(ITEM) Q
    14         . S ^TMP("ORWGRPC SORT",$J,DATE,ITEM)="" ;ADVERSE
    15         I FMT=6 D
    16         . S DATE=OLDEST
    17         . F  S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1  Q:DATE>NEWEST  D
    18         .. S ITEM=""
    19         .. F  S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM=""  D
    20         ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
    21         ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
    22         ... S CNT=CNT+1
    23         ... S RESULT="120.8^"_ITEM
    24         ... D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    25         I FMT'=6 D
    26         . S DATE=0
    27         . F  S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1  D
    28         .. S ITEM=""
    29         .. F  S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM=""  D
    30         ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
    31         ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
    32         ... S CNT=CNT+1
    33         ... I FMT=3 S RESULT="120.8^"_ITEM_"^^"_ITEM_"^^"_DATE
    34         ... I FMT=0 S RESULT="120.8^"_ITEM_U_ITEM
    35         ... D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    36         K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J)
    37         Q
    38         ;
    39 PL(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
    40         N DATE,ICD9,OK,PRIORITY,RESULT,STATUS
    41         K ^TMP("ORWGRPC TEMP",$J)
    42         S STATUS=""
    43         F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
    44         . S PRIORITY=""
    45         . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
    46         .. S ICD9=""
    47         .. F  S ICD9=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9)) Q:ICD9=""  D
    48         ... S OK=0
    49         ... I FMT=6 D
    50         .... S DATE=OLDEST
    51         .... F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    52         ..... S CNT=CNT+1
    53         ..... S OK=1
    54         ..... S RESULT=9000011_U_ICD9
    55         ... I FMT=3 D
    56         .... S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,""),-1)
    57         .... I DATE S ^TMP("ORWGRPC TEMP",$J,ICD9,DATE)=""
    58         ... I FMT=0 D
    59         .... S CNT=CNT+1
    60         .... S OK=1
    61         .... S RESULT=9000011_U_ICD9_U_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)
    62         ... I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    63         I FMT=3 D
    64         . S ICD9=""
    65         . F  S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9=""  D
    66         .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,""),-1)
    67         .. I 'DATE Q
    68         .. S CNT=CNT+1
    69         .. S RESULT=9000011_U_ICD9_"^^"_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)_"^^"_DATE
    70         .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    71         K ^TMP("ORWGRPC TEMP",$J)
    72         Q
    73         ;
    74 PLX(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)        ; from ORWGAPIR
    75         D PLX2^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP)
    76         Q
    77         ;
    78 REG(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP)   ; from ORWGAPIR
    79         N DATE,ICD,ITEM,NUM,OK,RESULT
    80         K ^TMP("ORWGRPC TEMP",$J)
    81         I $E(FILE,3,4)="DX" S ICD="ICD9"
    82         I $E(FILE,3,4)="OP" S ICD="ICD0"
    83         S NUM=""
    84         F  S NUM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM)) Q:NUM=""  D
    85         . S ITEM=""
    86         . F  S ITEM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM)) Q:ITEM=""  D
    87         .. S OK=0
    88         .. I FMT=6 D
    89         ... S DATE=OLDEST
    90         ... F  S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    91         .... S CNT=CNT+1
    92         .... S OK=1
    93         .... S RESULT=FILE_U_ITEM
    94         .. I FMT=3 D
    95         ... S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,""),-1)
    96         ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=""
    97         .. I FMT=0 D
    98         ... S CNT=CNT+1
    99         ... S OK=1
    100         ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)
    101         .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    102         I FMT=3 D
    103         . S ITEM=""
    104         . F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM=""  D
    105         .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1)
    106         .. I 'DATE Q
    107         .. S CNT=CNT+1
    108         .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)_"^^"_DATE
    109         .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    110         K ^TMP("ORWGRPC TEMP",$J)
    111         Q
    112         ;
     1ORWGAPI2 ; SLC/STAFF - Graph API Items ;12/21/05  08:16
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4ADMITS(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     5 N DATE,DATE2,DISCH,LINE,LST,NUM,OK,RESULT K LST
     6 K ^TMP("ORWGRPC TEMP",$J)
     7 D ADMITLST^ORWPT(.LST,DFN)
     8 S OK=0
     9 S NUM=0
     10 F  S NUM=$O(LST(NUM)) Q:NUM<1  D  Q:OK
     11 . S LINE=LST(NUM)
     12 . S DATE=$P(LINE,U)
     13 . S DISCH=$P(LINE,U,5)
     14 . S DATE2=$$DISCH^ORWGAPIA(DISCH)
     15 . I DATE2="" S DATE2=DATE2\1
     16 . I FMT=6 D  Q
     17 .. I DATE>NEWEST Q
     18 .. I DATE2>0,DATE2<OLDEST Q
     19 .. I $D(^TMP("ORWGRPC TEMP",$J,"ADMIT")) Q
     20 .. S ^TMP("ORWGRPC TEMP",$J,"ADMIT")=""
     21 .. S CNT=CNT+1
     22 .. S OK=1
     23 .. S RESULT="405^ADMIT"
     24 . I FMT=3 D  Q
     25 .. I $D(^TMP("ORWGRPC TEMP",$J,"ADMIT")) Q
     26 .. S ^TMP("ORWGRPC TEMP",$J,"ADMIT")=""
     27 .. S CNT=CNT+1
     28 .. S OK=1
     29 .. S RESULT="405^ADMIT^^ADMIT^^"_DATE
     30 . I FMT=0 D  Q
     31 .. S ^TMP("ORWGRPC TEMP",$J,"ADMIT")=""
     32 .. S CNT=CNT+1
     33 .. S OK=1
     34 .. S RESULT="405^ADMIT^ADMIT"
     35 I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     36 K ^TMP("ORWGRPC TEMP",$J)
     37 Q
     38 ;
     39ADVERSE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     40 N DATE,IEN,ITEM,RESULT
     41 K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J)
     42 S IEN=0
     43 F  S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN<1  D
     44 . I '$D(^GMR(120.8,IEN,0)) Q
     45 . I $G(^GMR(120.8,IEN,"ER")) Q
     46 . I '$P(^GMR(120.8,IEN,0),U,12) Q
     47 . S DATE=+$P($G(^GMR(120.8,IEN,0)),U,4) I 'DATE Q
     48 . S ITEM=$P(^GMR(120.8,IEN,0),U,2) I '$L(ITEM) Q
     49 . S ^TMP("ORWGRPC SORT",$J,DATE,ITEM)="" ;ADVERSE
     50 I FMT=6 D
     51 . S DATE=OLDEST
     52 . F  S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1  Q:DATE>NEWEST  D
     53 .. S ITEM=""
     54 .. F  S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM=""  D
     55 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
     56 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     57 ... S CNT=CNT+1
     58 ... S RESULT="120.8^"_ITEM
     59 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     60 I FMT'=6 D
     61 . S DATE=0
     62 . F  S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1  D
     63 .. S ITEM=""
     64 .. F  S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM=""  D
     65 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
     66 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     67 ... S CNT=CNT+1
     68 ... I FMT=3 S RESULT="120.8^"_ITEM_"^^"_ITEM_"^^"_DATE
     69 ... I FMT=0 S RESULT="120.8^"_ITEM_U_ITEM
     70 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     71 K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J)
     72 Q
     73 ;
     74PL(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     75 N DATE,ICD9,OK,PRIORITY,RESULT,STATUS
     76 K ^TMP("ORWGRPC TEMP",$J)
     77 S STATUS=""
     78 F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
     79 . S PRIORITY=""
     80 . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
     81 .. S ICD9=""
     82 .. F  S ICD9=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9)) Q:ICD9=""  D
     83 ... S OK=0
     84 ... I FMT=6 D
     85 .... S DATE=OLDEST
     86 .... F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     87 ..... S CNT=CNT+1
     88 ..... S OK=1
     89 ..... S RESULT=9000011_U_ICD9
     90 ... I FMT=3 D
     91 .... S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,""),-1)
     92 .... I DATE S ^TMP("ORWGRPC TEMP",$J,ICD9,DATE)=""
     93 ... I FMT=0 D
     94 .... S CNT=CNT+1
     95 .... S OK=1
     96 .... S RESULT=9000011_U_ICD9_U_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)
     97 ... I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     98 I FMT=3 D
     99 . S ICD9=""
     100 . F  S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9=""  D
     101 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,""),-1)
     102 .. I 'DATE Q
     103 .. S CNT=CNT+1
     104 .. S RESULT=9000011_U_ICD9_"^^"_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)_"^^"_DATE
     105 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     106 K ^TMP("ORWGRPC TEMP",$J)
     107 Q
     108 ;
     109PLX(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     110 D PLX2^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP)
     111 Q
     112 ;
     113REG(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     114 N DATE,ICD,ITEM,NUM,OK,RESULT
     115 K ^TMP("ORWGRPC TEMP",$J)
     116 I $E(FILE,3,4)="DX" S ICD="ICD9"
     117 I $E(FILE,3,4)="OP" S ICD="ICD0"
     118 S NUM=""
     119 F  S NUM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM)) Q:NUM=""  D
     120 . S ITEM=""
     121 . F  S ITEM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM)) Q:ITEM=""  D
     122 .. S OK=0
     123 .. I FMT=6 D
     124 ... S DATE=OLDEST
     125 ... F  S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     126 .... S CNT=CNT+1
     127 .... S OK=1
     128 .... S RESULT=FILE_U_ITEM
     129 .. I FMT=3 D
     130 ... S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,""),-1)
     131 ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=""
     132 .. I FMT=0 D
     133 ... S CNT=CNT+1
     134 ... S OK=1
     135 ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)
     136 .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     137 I FMT=3 D
     138 . S ITEM=""
     139 . F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM=""  D
     140 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1)
     141 .. I 'DATE Q
     142 .. S CNT=CNT+1
     143 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)_"^^"_DATE
     144 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     145 K ^TMP("ORWGRPC TEMP",$J)
     146 Q
     147 ;
     148SURGERY(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     149 N CASE,DATE,PROC,RESULT,RESULTS,SURG,SURGPROC K SURG,SURGPROC
     150 D SURG^ORWGAPIA(.SURG,DFN)
     151 K SURG(0),SURG(1)
     152 I FMT=6 D
     153 . S CASE=0
     154 . F  S CASE=$O(SURG(CASE)) Q:CASE<1  D
     155 .. S RESULTS=SURG(CASE)
     156 .. S PROC=$P(RESULTS,U,3)
     157 .. I '$L(PROC) Q
     158 .. S DATE=$P(RESULTS,U,5)
     159 .. I DATE>NEWEST Q
     160 .. I DATE<OLDEST Q
     161 .. I $D(SURGPROC(PROC)) Q
     162 .. S SURGPROC(PROC)=""
     163 .. S CNT=CNT+1
     164 .. S RESULT=130_U_PROC
     165 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     166 I FMT'=6 D
     167 . S CASE=0
     168 . F  S CASE=$O(SURG(CASE)) Q:CASE<1  D
     169 .. S RESULTS=SURG(CASE)
     170 .. S PROC=$P(RESULTS,U,3)
     171 .. I '$L(PROC) Q
     172 .. S SURGPROC(PROC)=RESULTS
     173 . K SURG S PROC=""
     174 . F  S PROC=$O(SURGPROC(PROC)) Q:PROC=""  D
     175 .. S CNT=CNT+1
     176 .. I FMT=3 S RESULT=130_U_PROC_"^^"_PROC_"^^"_$P(SURGPROC(PROC),U,5)
     177 .. I FMT=0 S RESULT=130_U_PROC_U_PROC
     178 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     179 Q
     180 ;
     181TREAT(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR ***** change to inverse dates
     182 N DATE,IEN,ITEM,OLDEST1,RESULT
     183 K ^TMP("ORWGRPC TEMP",$J)
     184 I FMT=6 D
     185 . S OLDEST1=9999999-OLDEST
     186 . S DATE=9999999-NEWEST
     187 . F  S DATE=$O(^AUPNVTRT("AA",DFN,DATE)) Q:DATE<1  Q:DATE>OLDEST1  D
     188 .. S IEN=0
     189 .. F  S IEN=$O(^AUPNVTRT("AA",DFN,DATE,IEN)) Q:IEN<1  D
     190 ... S ITEM=+$G(^AUPNVTRT(IEN,0)) I 'ITEM Q
     191 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
     192 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     193 ... S CNT=CNT+1
     194 ... S RESULT="9000010.15^"_ITEM
     195 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     196 I FMT'=6 D
     197 . S OLDEST1=9999999-OLDEST
     198 . S DATE=9999999-NEWEST
     199 . F  S DATE=$O(^AUPNVTRT("AA",DFN,DATE)) Q:DATE<1  Q:DATE>OLDEST  D
     200 .. S IEN=0
     201 .. F  S IEN=$O(^AUPNVTRT("AA",DFN,DATE,IEN)) Q:IEN<1  D
     202 ... S ITEM=+$G(^AUPNVTRT(IEN,0)) I 'ITEM Q
     203 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
     204 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     205 ... S CNT=CNT+1
     206 ... I FMT=3 S RESULT="9000010.15^"_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,9000010.15)_"^^"_DATE
     207 ... I FMT=0 S RESULT="9000010.15^"_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,9000010.15)
     208 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     209 K ^TMP("ORWGRPC TEMP",$J)
     210 Q
     211 ;
     212VISITS(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     213 N DATE,DATE2,ITEM,NODE,NUM,OK,RESULT
     214 K ^TMP("ORWGRPC TEMP",$J)
     215 I FMT=6 D
     216 . S DATE=0
     217 . F  S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE<1  Q:DATE>NEWEST  D
     218 .. S ITEM=""
     219 .. F  S ITEM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM)) Q:ITEM=""  D
     220 ... S NODE=""
     221 ... F  S NODE=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE)) Q:NODE=""  D
     222 .... S NUM=0
     223 .... F  S NUM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE,NUM)) Q:NUM=""  D
     224 ..... S DATE2=+$P($G(^AUPNVSIT(NUM,0)),U,18)
     225 ..... I 'DATE2 S DATE2=DATE+.01
     226 ..... I +$E($P(DATE2,".",2),1,2)>24 S DATE2=(DATE\1)+.2359
     227 ..... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=DATE2
     228 . S ITEM=0
     229 . F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM<1  D
     230 .. S OK=0
     231 .. S DATE=0
     232 .. F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE<1  Q:DATE>NEWEST  D  Q:OK
     233 ... S DATE2=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE))
     234 ... I DATE2<OLDEST Q
     235 ... S CNT=CNT+1
     236 ... S OK=1
     237 ... S RESULT="9000010^"_ITEM
     238 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     239 I FMT'=6 D
     240 . S DATE=0
     241 . F  S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE<1  D
     242 .. S ITEM=0
     243 .. F  S ITEM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM)) Q:ITEM<1  D
     244 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q
     245 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     246 ... S CNT=CNT+1
     247 ... I FMT=3 S RESULT="9000010^"_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,9000010,.22)_"^^"_DATE
     248 ... I FMT=0 S RESULT="9000010^"_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,9000010,.22)
     249 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     250 K ^TMP("ORWGRPC TEMP",$J)
     251 Q
     252 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI3.m

    r613 r623  
    1 ORWGAPI3        ; SLC/STAFF - Graph Data ;12/21/05  08:17
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ;
    5 ADVERSE(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)     ; from ORWGAPIR
    6         N ADVERSE,DATE,DATE2,NODE,RESULT,RXN,VALUE
    7         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    8         S ADVERSE=""
    9         S VALUE=ITEM_U_ITEM
    10         S NODE=""
    11         F  S NODE=$O(^GMR(120.8,"B",DFN,NODE)) Q:NODE=""  D
    12         . I '$D(^GMR(120.8,NODE,0)) Q
    13         . I $G(^GMR(120.8,NODE,"ER")) Q  ; entered in error
    14         . I '$P(^GMR(120.8,NODE,0),U,12) Q  ; signed
    15         . S DATE=+$P($G(^GMR(120.8,NODE,0)),U,4) I 'DATE Q
    16         . I DATE>START Q
    17         . I DATE<BACKTO Q
    18         . I ITEM'=$P(^GMR(120.8,NODE,0),U,2) Q
    19         . S RXN=0
    20         . F  S RXN=$O(^GMR(120.8,NODE,10,"B",RXN)) Q:RXN<1  D
    21         .. S ADVERSE=ADVERSE_$$EVALUE^ORWGAPIU(RXN,120.8)_", "
    22         . I $L(ADVERSE)>0 S ADVERSE=$E(ADVERSE,1,$L(ADVERSE)-2)
    23         . S CNT=CNT+1
    24         . S RESULT=120.8_U_ITEM_U_DATE_U_DATE2_U_ADVERSE
    25         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    26         Q
    27         ;
    28 DX(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)  ; from ORWGAPIR
    29         N DATE,DATE2,NODE,NUM,RESULT,VALUE,VALUES K VALUE
    30         K ^TMP("ORWGRPC TEMP",$J)
    31         S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    32         S NUM=""
    33         F  S NUM=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM)) Q:NUM=""  D
    34         . S DATE=""
    35         . F  S DATE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE)) Q:DATE=""  D
    36         .. I DATE>START Q
    37         .. I DATE<BACKTO Q
    38         .. S NODE=""
    39         .. F  S NODE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE=""  D
    40         ... I '$D(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=NODE_U_NUM
    41         S ITEM=""
    42         F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM=""  D
    43         . S DATE=""
    44         . F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE=""  D
    45         .. S NODE=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) I '$L(NODE) Q
    46         .. S NUM=$P(NODE,U,2)
    47         .. S NODE=$P(NODE,U)
    48         .. I '$L($G(^DGPT(+NODE,0))) Q  ; ****** remove this when PTF patch is released **********
    49         .. D PTF^ORWGAPIA(NODE,.VALUE,.VALUES) S VALUE=$$EXT^ORWGAPIX($G(VALUE("DISCHARGE STATUS")),45,6)
    50         .. I NUM="DXLS" S VALUE="(DXLS)  "_VALUE_U_U_VALUES ;*****************************
    51         .. S RESULT=45_"DX"_U_ITEM_U_DATE_U_DATE2_U_"  "_VALUE
    52         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    53         K ^TMP("ORWGRPC TEMP",$J)
    54         Q
    55         ;
    56 LAB(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR
    57         N COMMENT,DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE
    58         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    59         D
    60         . I $E(ITEM)="A" S TYPE="AP" Q
    61         . I $E(ITEM)="M" S TYPE="MI" Q
    62         . S TYPE="" Q
    63         F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    64         . I DATE>START Q
    65         . I DATE<BACKTO Q
    66         . S NODE=""
    67         . F  S NODE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    68         .. K VALUE
    69         .. D LAB^ORWGAPIC(.VALUE,NODE,ITEM)
    70         .. I TYPE="AP" S RESULT="63AP^"_ITEM_U_DATE_U_DATE2 ;_U_$P(VALUE,U,2)
    71         .. I TYPE="MI" S RESULT="63MI^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,4)
    72         .. I TYPE="" D
    73         ... S COMMENT=""
    74         ... I $L($G(VALUE("COMMENTS",1))) S COMMENT=1
    75         ... S RESULT="63^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,3)_U_$P(VALUE,U,4)_U_$G(VALUE("SPECIMEN"))_U_COMMENT
    76         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    77         Q
    78         ;
    79 MED(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR
    80         D MED3^ORWGAPIE(.DATA,ITEM,START,DFN,.CNT,.TMP)
    81         Q
    82         ;
    83 NOTE(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)        ; from ORWGAPIR
    84         N DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,RESULT,RESULTS,TITLE,VALUE K DUM
    85         K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
    86         S CNT=$G(CNT),ITEM=$$UP^ORWGAPIX(ITEM),BACKTO=+$G(BACKTO)
    87         F DOCTYPE="P","D","C" D
    88         . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
    89         . K ^TMP("TIUR",$J)
    90         . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN)
    91         . S DOC=0
    92         . F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
    93         .. S RESULTS=^TMP("TIUR",$J,DOC)
    94         .. S IEN=+$P(RESULTS,U)
    95         .. S TITLE=$$UP^ORWGAPIX($P(RESULTS,U,2))
    96         .. I TITLE'=ITEM Q
    97         .. ; do not use admission date S DATE=$P($G(^AUPNVSIT(+$P($G(^TIU(8925,IEN,0)),U,3),0)),U)
    98         .. S DATE=$P(RESULTS,U,3)
    99         .. I DATE>START Q
    100         .. I DATE<BACKTO Q
    101         .. S VALUE=$P(RESULTS,U,7)
    102         .. S CNT=CNT+1
    103         .. S RESULT=8925_U_TITLE_U_DATE_"^^"_VALUE
    104         .. I $D(^TMP("ORWGRPC TEMP",$J,RESULT)) Q
    105         .. S ^TMP("ORWGRPC TEMP",$J,RESULT)=""
    106         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    107         K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
    108         Q
    109         ;
    110 ORDER(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)       ; from ORWGAPIR
    111         N DATE,DATE2,NODE,ORUPCHUK,RESULT,VALUE K ORUPCHUK
    112         S DATE="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    113         F  S DATE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    114         . I DATE>START Q
    115         . I DATE<BACKTO Q
    116         . S DATE2=""
    117         . F  S DATE2=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2=""  D
    118         .. S NODE=""
    119         .. F  S NODE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE=""  D
    120         ... D EN^ORX8($P(NODE,";")) S VALUE=$P($G(ORUPCHUK("ORSTS")),U,2)
    121         ... S RESULT=100_U_ITEM_U_DATE_"^^"_VALUE
    122         ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    123         Q
    124         ;
    125 RAD(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR
    126         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    127         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    128         F  S DATE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    129         . I DATE>START Q
    130         . I DATE<BACKTO Q
    131         . S NODE=""
    132         . F  S NODE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    133         .. D RAD^ORWGAPIA(NODE,.VALUE,.VALUES) S VALUE=$G(VALUE("PDX"))_"-"_$G(VALUE("EXAM STATUS"))_U_U_VALUES
    134         .. S RESULT=70_U_ITEM_U_DATE_U_DATE2_U_VALUE
    135         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    136         Q
    137         ;
     1ORWGAPI3 ; SLC/STAFF - Graph Data ;12/21/05  08:17
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4 ;
     5ADVERSE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     6 N ADVERSE,DATE,DATE2,NODE,RESULT,RXN,VALUE
     7 S DATE="",DATE2="",CNT=$G(CNT)
     8 S ADVERSE=""
     9 S VALUE=ITEM_U_ITEM
     10 S NODE=""
     11 F  S NODE=$O(^GMR(120.8,"B",DFN,NODE)) Q:NODE=""  D
     12 . I '$D(^GMR(120.8,NODE,0)) Q
     13 . I $G(^GMR(120.8,NODE,"ER")) Q  ; entered in error
     14 . I '$P(^GMR(120.8,NODE,0),U,12) Q  ; signed
     15 . S DATE=+$P($G(^GMR(120.8,NODE,0)),U,4) I 'DATE Q
     16 . I DATE>START Q
     17 . I ITEM'=$P(^GMR(120.8,NODE,0),U,2) Q
     18 . S RXN=0
     19 . F  S RXN=$O(^GMR(120.8,NODE,10,"B",RXN)) Q:RXN<1  D
     20 .. S ADVERSE=ADVERSE_$$EVALUE^ORWGAPIU(RXN,120.8)_", "
     21 . I $L(ADVERSE)>0 S ADVERSE=$E(ADVERSE,1,$L(ADVERSE)-2)
     22 . S CNT=CNT+1
     23 . S RESULT=120.8_U_ITEM_U_DATE_U_DATE2_U_ADVERSE
     24 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     25 Q
     26 ;
     27BCMA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     28 N DATE,NODE,RESULT,VALUE
     29 S DATE="",CNT=$G(CNT)
     30 F  S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE)) Q:DATE=""  D
     31 . I DATE>START Q
     32 . S NODE=""
     33 . F  S NODE=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     34 .. S VALUE=$P($G(^PSB(53.79,NODE,0)),U,9) I VALUE'="G" Q
     35 .. S RESULT=53.79_U_ITEM_U_DATE_"^^"
     36 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     37 Q
     38 ;
     39DX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     40 N DATE,DATE2,NODE,NUM,RESULT,VALUE K VALUE
     41 K ^TMP("ORWGRPC TEMP",$J)
     42 S DATE2="",CNT=$G(CNT)
     43 S NUM=""
     44 F  S NUM=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM)) Q:NUM=""  D
     45 . S DATE=""
     46 . F  S DATE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE)) Q:DATE=""  D
     47 .. I DATE>START Q
     48 .. S NODE=""
     49 .. F  S NODE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE=""  D
     50 ... I '$D(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=NODE_U_NUM
     51 S ITEM=""
     52 F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM=""  D
     53 . S DATE=""
     54 . F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE=""  D
     55 .. S NODE=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) I '$L(NODE) Q
     56 .. S NUM=$P(NODE,U,2)
     57 .. S NODE=$P(NODE,U)
     58 .. D PTF^ORWGAPIA(NODE,.VALUE) S VALUE=$$EXT^ORWGAPIX($G(VALUE("DISCHARGE STATUS")),45,6)
     59 .. I NUM="DXLS" S VALUE="(DXLS)  "_VALUE
     60 .. S RESULT=45_"DX"_U_ITEM_U_DATE_U_DATE2_U_"  "_VALUE
     61 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     62 K ^TMP("ORWGRPC TEMP",$J)
     63 Q
     64 ;
     65INRX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     66 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     67 S DATE="",CNT=$G(CNT)
     68 F  S DATE=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     69 . I DATE>START Q
     70 . S DATE2=""
     71 . F  S DATE2=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2=""  D
     72 .. S NODE=""
     73 .. F  S NODE=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE=""  D
     74 ... D RXIN^ORWGAPIA(NODE,.VALUE) S VALUE=VALUE("STAT")
     75 ... S VALUE=VALUE_"  "_$$INSIG^ORWGAPIA(NODE)
     76 ... S RESULT=55_U_ITEM_U_DATE_U_DATE2_U_VALUE
     77 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     78 Q
     79 ;
     80LAB(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     81 N COMMENT,DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE
     82 S DATE="",DATE2="",CNT=$G(CNT)
     83 D
     84 . I $E(ITEM)="A" S TYPE="AP" Q
     85 . I $E(ITEM)="M" S TYPE="MI" Q
     86 . S TYPE="" Q
     87 F  S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     88 . I DATE>START Q
     89 . S NODE=""
     90 . F  S NODE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     91 .. K VALUE
     92 .. D LAB^ORWGAPIA(.VALUE,NODE,ITEM)
     93 .. I TYPE="AP" S RESULT="63AP^"_ITEM_U_DATE_U_DATE2 ;_U_$P(VALUE,U,2)
     94 .. I TYPE="MI" S RESULT="63MI^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,4)
     95 .. I TYPE="" D
     96 ... S COMMENT=""
     97 ... I $L($G(VALUE("COMMENTS",1))) S COMMENT=1
     98 ... S RESULT="63^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,3)_U_$P(VALUE,U,4)_U_$G(VALUE("SPECIMEN"))_U_COMMENT
     99 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     100 Q
     101 ;
     102MED(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     103 D MED3^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP)
     104 Q
     105 ;
     106NOTE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     107 N DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,RESULT,RESULTS,TITLE,VALUE K DUM
     108 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
     109 S CNT=$G(CNT),ITEM=$$UP^ORWGAPIX(ITEM)
     110 F DOCTYPE="P","D","C" D
     111 . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
     112 . K ^TMP("TIUR",$J)
     113 . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN)
     114 . S DOC=0
     115 . F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
     116 .. S RESULTS=^TMP("TIUR",$J,DOC)
     117 .. S IEN=+$P(RESULTS,U)
     118 .. S TITLE=$$UP^ORWGAPIX($P(RESULTS,U,2))
     119 .. I TITLE'=ITEM Q
     120 .. ; do not use admission date S DATE=$P($G(^AUPNVSIT(+$P($G(^TIU(8925,IEN,0)),U,3),0)),U)
     121 .. S DATE=$P(RESULTS,U,3)
     122 .. I DATE>START Q
     123 .. S VALUE=$P(RESULTS,U,7)
     124 .. S CNT=CNT+1
     125 .. S RESULT=8925_U_TITLE_U_DATE_"^^"_VALUE
     126 .. I $D(^TMP("ORWGRPC TEMP",$J,RESULT)) Q
     127 .. S ^TMP("ORWGRPC TEMP",$J,RESULT)=""
     128 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     129 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J)
     130 Q
     131 ;
     132NVAE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     133 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     134 S DATE="",CNT=$G(CNT)
     135 F  S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE=""  D
     136 . I DATE>START Q
     137 . S DATE2=""
     138 . F  S DATE2=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE2)) Q:DATE2=""  D
     139 .. S NODE=""
     140 .. F  S NODE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE=""  D
     141 ... D RXNVA^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("STATUS"))
     142 ... S VALUE=VALUE_"  "_$$NVASIG^ORWGAPIA(NODE)
     143 ... S RESULT="55NVAE"_U_ITEM_U_DATE_"^^"_VALUE ; DATE2 is not used, NVA defined as an event
     144 ... ;S RESULT="55NVAE"_U_ITEM_U_DATE_U_$S(DATE2["U":DT,1:DATE2)_U_VALUE ; DATE2 is not used, NVA defined as an event
     145 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     146 Q
     147 ;
     148NVA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     149 D NVA3^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP)
     150 Q
     151 ;
     152ORDER(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     153 N DATE,DATE2,NODE,ORUPCHUK,RESULT,VALUE K ORUPCHUK
     154 S DATE="",CNT=$G(CNT)
     155 F  S DATE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     156 . I DATE>START Q
     157 . S DATE2=""
     158 . F  S DATE2=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2=""  D
     159 .. S NODE=""
     160 .. F  S NODE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE=""  D
     161 ... D EN^ORX8($P(NODE,";")) S VALUE=$P($G(ORUPCHUK("ORSTS")),U,2)
     162 ... S RESULT=100_U_ITEM_U_DATE_"^^"_VALUE
     163 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     164 Q
     165 ;
     166OUTRX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     167 N DATE1,DATE2,LNUM,NODE,RESULT,VALUE K VALUE
     168 S DATE1="",DATE2="",CNT=$G(CNT)
     169 F  S DATE1=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1)) Q:DATE1=""  D
     170 . I DATE1>START Q
     171 . S DATE2=""
     172 . F  S DATE2=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1,DATE2)) Q:DATE2=""  D
     173 .. S NODE=""
     174 .. F  S NODE=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1,DATE2,NODE)) Q:NODE=""  D
     175 ... D RXOUT^ORWGAPIA(NODE,.VALUE) S VALUE=$$EXTERNAL^ORWGAPIX(52,100,"",VALUE("STATUS"))
     176 ... S VALUE=VALUE_"  "_$$SIG^ORWGAPIA(DFN,+NODE)
     177 ... S RESULT=52_U_ITEM_U_DATE1_U_DATE2_U_VALUE
     178 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     179 Q
     180 ;
     181RAD(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     182 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     183 S DATE="",DATE2="",CNT=$G(CNT)
     184 F  S DATE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     185 . I DATE>START Q
     186 . S NODE=""
     187 . F  S NODE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     188 .. D RAD^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("PDX"))_"-"_$G(VALUE("EXAM STATUS"))
     189 .. S RESULT=70_U_ITEM_U_DATE_U_DATE2_U_VALUE
     190 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     191 Q
     192 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI4.m

    r613 r623  
    1 ORWGAPI4        ; SLC/STAFF - Graph Data, indexed ;8/21/06  07:52
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 EDU(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR
    5         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    6         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    7         F  S DATE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    8         . I DATE>START Q
    9         . I DATE<BACKTO Q
    10         . S NODE=""
    11         . F  S NODE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    12         .. D EDU^ORWGAPIA(NODE,.VALUE,.VALUES)
    13         .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.16,.06)_U_VALUES ;*****************************
    14         .. S RESULT=9000010.16_U_ITEM_U_DATE_"^^" ;_VALUE
    15         .. S RESULT=9000010.16_U_ITEM_U_DATE_U_DATE2_U ;_VALUE
    16         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    17         Q
    18         ;
    19 EXAM(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)        ; from ORWGAPIR
    20         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    21         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    22         F  S DATE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    23         . I DATE>START Q
    24         . I DATE<BACKTO Q
    25         . S NODE=""
    26         . F  S NODE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    27         .. D EXAM^ORWGAPIA(NODE,.VALUE,.VALUES)
    28         .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.13,.04)_U_VALUES ;*****************************
    29         .. S RESULT=9000010.13_U_ITEM_U_DATE_U_DATE2_U_VALUE
    30         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    31         Q
    32         ;
    33 HF(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)  ; from ORWGAPIR
    34         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    35         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    36         F  S DATE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    37         . I DATE>START Q
    38         . I DATE<BACKTO Q
    39         . S NODE=""
    40         . F  S NODE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    41         .. D HF^ORWGAPIA(NODE,.VALUE,.VALUES)
    42         .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.23,.04)_U_VALUES ;*****************************
    43         .. S RESULT=9000010.23_U_ITEM_U_DATE_U_DATE2_U_VALUE
    44         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    45         Q
    46         ;
    47 IMM(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR
    48         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    49         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    50         F  S DATE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    51         . I DATE>START Q
    52         . I DATE<BACKTO Q
    53         . S NODE=""
    54         . F  S NODE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    55         .. D IMM^ORWGAPIA(NODE,.VALUE,.VALUES)
    56         .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.11,.04)_U_VALUES ;*****************************
    57         .. S CNT=CNT+1
    58         .. S RESULT=9000010.11_U_ITEM_U_DATE_U_DATE2_U_VALUE
    59         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    60         Q
    61         ;
    62 MH(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)  ; from ORWGAPIR
    63         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    64         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    65         F  S DATE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    66         . I DATE>START Q
    67         . I DATE<BACKTO Q
    68         . S NODE=""
    69         . F  S NODE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    70         .. D MH^ORWGAPIA(.VALUE,NODE,.VALUES) S VALUE=$P($G(VALUE(2)),U,2,3)_U_VALUES ;*****************************
    71         .. S RESULT=601.2_U_ITEM_U_DATE_U_DATE2_U ;_VALUE
    72         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    73         Q
    74         ;
    75 OP(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)  ; from ORWGAPIR
    76         N DATE,DATE2,NODE,NUM,RESULT,VALUE,VALUES K VALUE
    77         S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO),VALUES=""
    78         S NUM=""
    79         F  S NUM=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM)) Q:NUM=""  D
    80         . S DATE=""
    81         . F  S DATE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE)) Q:DATE=""  D
    82         .. I DATE>START Q
    83         .. I DATE<BACKTO Q
    84         .. S NODE=""
    85         .. F  S NODE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE=""  D
    86         ... I '$L($G(^DGPT(+NODE,0))) Q  ; ****** remove this when PTF patch is released **********
    87         ... D PTF^ORWGAPIA(NODE,.VALUE,.VALUES) S VALUE=$G(VALUE("DISCHARGE STATUS"))_U_VALUES ;*****************************
    88         ... S RESULT=45_"OP"_U_ITEM_U_DATE_U_DATE2_U ;_VALUE
    89         ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    90         Q
    91         ;
    92 POV(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR
    93         N DATE,DATE2,NODE,RESULT,TYPE,VALUE,VALUES K VALUE
    94         S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    95         S TYPE=""
    96         F  S TYPE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE)) Q:TYPE=""  D
    97         . S DATE=""
    98         . F  S DATE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
    99         .. I DATE>START Q
    100         .. I DATE<BACKTO Q
    101         .. S NODE=""
    102         .. F  S NODE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE=""  D
    103         ... D POV^ORWGAPIA(NODE,.VALUE,.VALUES)
    104         ... S VALUE=VALUE("CLINICAL TERM"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.07,.15)_U_VALUES ;*****************************
    105         ... S CNT=CNT+1
    106         ... S RESULT=9000010.07_U_ITEM_U_DATE_U_DATE2_U_VALUE
    107         ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    108         Q
    109         ;
    110 PROB(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)        ; from ORWGAPIR
    111         N DATE,DATE2,DTONSET,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE
    112         K ^TMP("ORWGRPC TEMP",$J)
    113         S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    114         S STATUS=""
    115         F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
    116         . S PRIORITY=""
    117         . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
    118         .. S DATE=""
    119         .. F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
    120         ... I DATE>START Q
    121         ... I DATE<BACKTO Q
    122         ... S NODE=""
    123         ... F  S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE=""  D
    124         .... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE,NODE)=""
    125         S ICD9=""
    126         F  S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9=""  D
    127         . S DATE=""
    128         . F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE)) Q:DATE=""  D
    129         .. S NODE=""
    130         .. F  S NODE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE,NODE)) Q:NODE=""  D
    131         ... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE)
    132         ... S RESULT=9000011_U_ITEM_U_DTONSET_U_DATE2_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12)
    133         ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    134         K ^TMP("ORWGRPC TEMP",$J)
    135         Q
    136         ;
    137 PROBX(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)       ; from ORWGAPIR
    138         D PROBX4^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP)
    139         Q
    140         ;
    141 PROC(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)        ; from ORWGAPIR
    142         N DATE,DATE2,NODE,RESULT,TYPE,VALUE,VALUES K VALUE
    143         S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    144         S TYPE=""
    145         F  S TYPE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE)) Q:TYPE=""  D
    146         . S DATE=""
    147         . F  S DATE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
    148         .. I DATE>START Q
    149         .. I DATE<BACKTO Q
    150         .. S NODE=""
    151         .. F  S NODE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE=""  D
    152         ... D CPT^ORWGAPIA(NODE,.VALUE,.VALUES)
    153         ... S VALUE=VALUE("PRINCIPAL PROCEDURE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.18,.07)_U_VALUES ;*****************************
    154         ... S RESULT=9000010.18_U_ITEM_U_DATE_U_DATE2_U_VALUE
    155         ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    156         Q
    157         ;
    158 SKIN(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)        ; from ORWGAPIR
    159         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    160         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    161         F  S DATE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    162         . I DATE>START Q
    163         . I DATE<BACKTO Q
    164         . S NODE=""
    165         . F  S NODE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    166         .. D SKIN^ORWGAPIA(NODE,.VALUE,.VALUES)
    167         .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.12,.04)_U_VALUES ;*****************************
    168         .. S CNT=CNT+1
    169         .. S RESULT=9000010.12_U_ITEM_U_DATE_U_DATE2_U_VALUE
    170         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    171         Q
    172         ;
    173 VITAL(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)       ; from ORWGAPIR
    174         I ITEM=99999 D BMIDATA^ORWGAPIX(.DATA,ITEM,START,DFN,.CNT,TMP) Q
    175         N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE
    176         S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    177         F  S DATE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
    178         . I DATE>START Q
    179         . I DATE<BACKTO Q
    180         . S NODE=""
    181         . F  S NODE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
    182         .. D VITAL^ORWGAPIA(.VALUE,NODE,.VALUES) S VALUE=$P($G(VALUE(7)),U)
    183         .. I $P($G(VALUE(3)),U,2)="PAIN",VALUE=99 S VALUE="(99)"
    184         .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_VALUE_U_U_VALUES ;*****************************
    185         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    186         Q
    187         ;
     1ORWGAPI4 ; SLC/STAFF - Graph Data ;8/21/06  07:52
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
     3 ;
     4ADMIT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     5 N DATE,DATE2,DISCH,LINE,LST,NUM,RESULT,VALUE K LST
     6 S ITEM=$G(ITEM,"ADMIT")
     7 D ADMITLST^ORWPT(.LST,DFN)
     8 S NUM=0
     9 F  S NUM=$O(LST(NUM)) Q:NUM<1  D
     10 . S LINE=LST(NUM)
     11 . S DATE=$P(LINE,U)
     12 . I DATE>START Q
     13 . S DISCH=$P(LINE,U,5)
     14 . S DATE2=$$DISCH^ORWGAPIA(DISCH)
     15 . I DATE2="" D
     16 .. S DATE2=$$FMADD^ORWGAPIX(DATE,$$LOS^ORWGAPIA(DISCH)+1)
     17 .. I DATE2=-1 S DATE2=$$FMADD^ORWGAPIX(DT,1) ; just make it today + 1
     18 .. S DATE2=DATE2\1
     19 . S VALUE=$P(LINE,U,3)_"  "_$P(LINE,U,4)_U_$P(LINE,U,5,6)
     20 . S CNT=CNT+1
     21 . S RESULT=405_U_ITEM_U_DATE_U_DATE2_U_VALUE
     22 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     23 Q
     24 ;
     25EDU(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     26 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     27 S DATE="",DATE2="",CNT=$G(CNT)
     28 F  S DATE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     29 . I DATE>START Q
     30 . S NODE=""
     31 . F  S NODE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     32 .. D EDU^ORWGAPIA(NODE,.VALUE)
     33 .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.16,.06)
     34 .. S RESULT=9000010.16_U_ITEM_U_DATE_"^^" ;_VALUE
     35 .. S RESULT=9000010.16_U_ITEM_U_DATE_U_DATE2_U ;_VALUE
     36 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     37 Q
     38 ;
     39EXAM(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     40 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     41 S DATE="",DATE2="",CNT=$G(CNT)
     42 F  S DATE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     43 . I DATE>START Q
     44 . S NODE=""
     45 . F  S NODE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     46 .. D EXAM^ORWGAPIA(NODE,.VALUE)
     47 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.13,.04)
     48 .. S RESULT=9000010.13_U_ITEM_U_DATE_U_DATE2_U_VALUE
     49 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     50 Q
     51 ;
     52HF(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     53 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     54 S DATE="",DATE2="",CNT=$G(CNT)
     55 F  S DATE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     56 . I DATE>START Q
     57 . S NODE=""
     58 . F  S NODE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     59 .. D HF^ORWGAPIA(NODE,.VALUE)
     60 .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.23,.04)
     61 .. S RESULT=9000010.23_U_ITEM_U_DATE_U_DATE2_U_VALUE
     62 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     63 Q
     64 ;
     65IMM(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     66 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     67 S DATE="",DATE2="",CNT=$G(CNT)
     68 F  S DATE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     69 . I DATE>START Q
     70 . S NODE=""
     71 . F  S NODE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     72 .. D IMM^ORWGAPIA(NODE,.VALUE)
     73 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.11,.04)
     74 .. S CNT=CNT+1
     75 .. S RESULT=9000010.11_U_ITEM_U_DATE_U_DATE2_U_VALUE
     76 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     77 Q
     78 ;
     79MH(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     80 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     81 S DATE="",DATE2="",CNT=$G(CNT)
     82 F  S DATE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     83 . I DATE>START Q
     84 . S NODE=""
     85 . F  S NODE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     86 .. D MH^ORWGAPIA(.VALUE,NODE) S VALUE=$P($G(VALUE(2)),U,2,3)
     87 .. S RESULT=601.2_U_ITEM_U_DATE_U_DATE2_U ;_VALUE
     88 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     89 Q
     90 ;
     91OP(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     92 N DATE,DATE2,NODE,NUM,RESULT,VALUE K VALUE
     93 S DATE2="",CNT=$G(CNT)
     94 S NUM=""
     95 F  S NUM=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM)) Q:NUM=""  D
     96 . S DATE=""
     97 . F  S DATE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE)) Q:DATE=""  D
     98 .. I DATE>START Q
     99 .. S NODE=""
     100 .. F  S NODE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE=""  D
     101 ... D PTF^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("DISCHARGE STATUS"))
     102 ... S RESULT=45_"OP"_U_ITEM_U_DATE_U_DATE2_U ;_VALUE
     103 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     104 Q
     105 ;
     106POV(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     107 N DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE
     108 S DATE2="",CNT=$G(CNT)
     109 S TYPE=""
     110 F  S TYPE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE)) Q:TYPE=""  D
     111 . S DATE=""
     112 . F  S DATE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
     113 .. I DATE>START Q
     114 .. S NODE=""
     115 .. F  S NODE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE=""  D
     116 ... D POV^ORWGAPIA(NODE,.VALUE)
     117 ... S VALUE=VALUE("CLINICAL TERM"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.07,.15)
     118 ... S CNT=CNT+1
     119 ... S RESULT=9000010.07_U_ITEM_U_DATE_U_DATE2_U_VALUE
     120 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     121 Q
     122 ;
     123PROB(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     124 N DATE,DATE2,DTONSET,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE
     125 K ^TMP("ORWGRPC TEMP",$J)
     126 S DATE2="",CNT=$G(CNT)
     127 S STATUS=""
     128 F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
     129 . S PRIORITY=""
     130 . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
     131 .. S DATE=""
     132 .. F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
     133 ... I DATE>START Q
     134 ... S NODE=""
     135 ... F  S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE=""  D
     136 .... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE,NODE)=""
     137 S ICD9=""
     138 F  S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9=""  D
     139 . S DATE=""
     140 . F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE)) Q:DATE=""  D
     141 .. S NODE=""
     142 .. F  S NODE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE,NODE)) Q:NODE=""  D
     143 ... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE)
     144 ... S RESULT=9000011_U_ITEM_U_DTONSET_U_DATE2_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12)
     145 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     146 K ^TMP("ORWGRPC TEMP",$J)
     147 Q
     148 ;
     149PROBX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     150 D PROBX4^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP)
     151 Q
     152 ;
     153PROC(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     154 N DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE
     155 S DATE2="",CNT=$G(CNT)
     156 S TYPE=""
     157 F  S TYPE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE)) Q:TYPE=""  D
     158 . S DATE=""
     159 . F  S DATE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
     160 .. I DATE>START Q
     161 .. S NODE=""
     162 .. F  S NODE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE=""  D
     163 ... D CPT^ORWGAPIA(NODE,.VALUE)
     164 ... S VALUE=VALUE("PRINCIPAL PROCEDURE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.18,.07)
     165 ... S RESULT=9000010.18_U_ITEM_U_DATE_U_DATE2_U_VALUE
     166 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     167 Q
     168 ;
     169SKIN(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     170 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     171 S DATE="",DATE2="",CNT=$G(CNT)
     172 F  S DATE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     173 . I DATE>START Q
     174 . S NODE=""
     175 . F  S NODE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     176 .. D SKIN^ORWGAPIA(NODE,.VALUE)
     177 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.12,.04)
     178 .. S CNT=CNT+1
     179 .. S RESULT=9000010.12_U_ITEM_U_DATE_U_DATE2_U_VALUE
     180 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     181 Q
     182 ;
     183SURG(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     184 N CASE,DATE,DATE2,NUM,PROC,RESULT,RESULTS,SURG,SURGPROC,VALUE K SURG,SURGPROC
     185 S DATE2="",CNT=$G(CNT)
     186 D SURG^ORWGAPIA(.SURG,DFN)
     187 K SURG(0),SURG(1)
     188 S ITEM=$$UP^ORWGAPIX(ITEM)
     189 S NUM=0
     190 S CASE=0
     191 F  S CASE=$O(SURG(CASE)) Q:CASE<1  D
     192 . S RESULTS=SURG(CASE)
     193 . S PROC=$P(RESULTS,U,3)
     194 . I '$L(PROC) Q
     195 . S PROC=$$UP^ORWGAPIX(PROC)
     196 . I PROC'=ITEM Q
     197 . S NUM=NUM+1
     198 . S SURGPROC(PROC,NUM)=RESULTS
     199 K SURG
     200 S PROC=""
     201 F  S PROC=$O(SURGPROC(PROC)) Q:PROC=""  D
     202 . S NUM=0
     203 . F  S NUM=$O(SURGPROC(PROC,NUM)) Q:NUM<1  D
     204 .. S RESULTS=SURGPROC(PROC,NUM)
     205 .. S DATE=$P(RESULTS,U,5)
     206 .. I DATE>START Q
     207 .. S VALUE=""
     208 .. S RESULT=130_U_PROC_U_DATE_U_DATE2_U_VALUE
     209 .. S CNT=CNT+1
     210 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     211 Q
     212 ;
     213TREAT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     214 N DATE,DATE2,NODE,RESULT,VALUE
     215 S DATE="",DATE2="",CNT=$G(CNT)
     216 S NODE=""
     217 F  S NODE=$O(^AUPNVTRT("C",DFN,NODE)) Q:NODE=""  D
     218 . I '$D(^AUPNVTRT("B",ITEM,NODE)) Q
     219 . S DATE=+$G(^AUPNVSIT(+$P($G(^AUPNVTRT(NODE,0)),U,3),0)) I 'DATE Q
     220 . I DATE>START Q
     221 . S VALUE=+$P($G(^AUPNVTRT(NODE,0)),U,4)
     222 . S CNT=CNT+1
     223 . S RESULT=9000010.15_U_ITEM_U_DATE_U_DATE2_U_VALUE
     224 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     225 Q
     226 ;
     227VISIT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     228 N DATE,DATE2,NODE,NUM,RESULT,VALUE
     229 S DATE="",DATE2="",CNT=$G(CNT)
     230 F  S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE=""  D
     231 . I DATE>START Q
     232 . S NODE=""
     233 . F  S NODE=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE)) Q:NODE=""  D
     234 .. S NUM=0
     235 .. F  S NUM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE,NUM)) Q:NUM=""  D
     236 ... S DATE2=+$P($G(^AUPNVSIT(NUM,0)),U,18)
     237 ... I 'DATE2 S DATE2=DATE+.01
     238 ... I +$E($P(DATE2,".",2),1,2)>24 S DATE2=(DATE\1)+.2359
     239 ... S VALUE=""
     240 ... S CNT=CNT+1
     241 ... S RESULT=9000010_U_ITEM_U_DATE_U_DATE2_U_VALUE
     242 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     243 Q
     244 ;
     245VITAL(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     246 I ITEM=99999 D BMIDATA^ORWGAPIX(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     247 N DATE,DATE2,NODE,RESULT,VALUE K VALUE
     248 S DATE="",DATE2="",CNT=$G(CNT)
     249 F  S DATE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
     250 . I DATE>START Q
     251 . S NODE=""
     252 . F  S NODE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE,NODE)) Q:NODE=""  D
     253 .. D VITAL^ORWGAPIA(.VALUE,NODE) S VALUE=$P($G(VALUE(7)),U)
     254 .. I $P($G(VALUE(3)),U,2)="PAIN",VALUE=99 S VALUE="(99)"
     255 .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_VALUE
     256 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     257 Q
     258 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIA.m

    r613 r623  
    1 ORWGAPIA        ; SLC/STAFF - Graph Application Calls ;2/22/07  11:16
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,251,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 ADMITX(DFN)     ; $$(dfn) -> 1 if patient has data else 0
    5         Q $O(^DGPM("C",+$G(DFN),0))>0
    6         ;
    7 ALLERGYX(DFN)   ; $$(dfn) -> 1 if patient has data else 0
    8         Q $O(^GMR(120.8,"B",+$G(DFN),0))>0
    9         ;
    10 ALLG(IEN)       ; $$(ien) -> external display of allergies
    11         I IEN Q $P($G(^GMRD(120.83,IEN,0)),U) ; this is for rxn, allergy is free text
    12         Q IEN
    13         ;
    14 CPT(NODE,ORVALUE,VALUES)        ; from ORWGAPI4
    15         D VCPT^PXPXRM(NODE,.ORVALUE)
    16         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    17         Q
    18         ;
    19 DISCH(IEN)      ; $$(pt movement ien) -> discharge date
    20         Q $P($G(^DGPM(+$P($G(^DGPM(+$G(IEN),0)),U,17),0)),U)
    21         ;
    22 DOCCLASS(DOCTYPE)       ; $$(doc type) -> ien of tiu doc class
    23         N CONSULTS
    24         S DOCTYPE=$E(DOCTYPE,1)
    25         I DOCTYPE="P" Q 3
    26         I DOCTYPE="D" Q 244
    27         I DOCTYPE="C" D CNSLCLAS^TIUSRVD(.CONSULTS) Q CONSULTS
    28         Q 0
    29         ;
    30 EDU(NODE,ORVALUE,VALUES)        ; from ORWGAPI4
    31         D VPEDU^PXPXRM(NODE,.ORVALUE)
    32         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    33         Q
    34         ;
    35 EXAM(NODE,ORVALUE,VALUES)       ; from ORWGAPI4
    36         D VXAM^PXPXRM(NODE,.ORVALUE)
    37         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    38         Q
    39         ;
    40 GETTIU(ORDATA,IEN)      ; from ORWGAPID
    41         D TGET^TIUSRVR1(.ORDATA,IEN)
    42         Q
    43         ;
    44 HF(NODE,ORVALUE,VALUES) ; from ORWGAPI4
    45         D VHF^PXPXRM(NODE,.ORVALUE)
    46         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    47         Q
    48         ;
    49 ICD0(IEN)       ; $$(ien) -> external display of IDC0
    50         Q $P($G(^ICD0(IEN,0)),U)_" "_$P($G(^ICD0(IEN,0)),U,4)
    51         ;
    52 ICD9(IEN)       ; $$(ien) -> external display of IDC9
    53         Q $P($G(^ICD9(IEN,0)),U)_" "_$P($G(^ICD9(IEN,0)),U,3)
    54         ;
    55 ICPT(IEN,CSD)   ; $$(ien) -> external display of CPT
    56         N X S X=$$CPT^ICPTCOD($G(IEN),$G(CSD))
    57         Q $P(X,U,2)_" "_$E($P(X,U,3),1,30)
    58         ;
    59 IMM(NODE,ORVALUE,VALUES)        ; from ORWGAPI4
    60         D VIMM^PXPXRM(NODE,.ORVALUE)
    61         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    62         Q
    63         ;
    64 ISA(USER,CLASS,ORERR)   ; $$(user,user class,err) -> 1 if user in class, else 0
    65         Q $$ISA^USRLM(USER,CLASS,.ORERR)
    66         ;
    67 LOS(DGPMIFN)    ; $$(pt movement ien) -> length of stay
    68         N X D ^DGPMLOS
    69         Q +$P($G(X),U,5)
    70         ;
    71 MEDICINE(ARRAY,DFN)     ;
    72         N DATE,FILE,IEN,NAME,NUM,REF,VALUES,XREF
    73         K ARRAY,^TMP("MCAR",$J),^TMP("OR",$J,"MCAR")
    74         D FILE^ORWGAPIU(690,.REF,.XREF)
    75         I '$L(REF) Q
    76         I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")"
    77         I $E(REF,$L(REF))="(" S REF=$P(REF,"(")
    78         D EN^MCARPS2(DFN)
    79         S NUM=0
    80         F  S NUM=$O(^TMP("OR",$J,"MCAR","OT",NUM)) Q:NUM<1  D
    81         . S VALUES=^TMP("OR",$J,"MCAR","OT",NUM)
    82         . S DATE=$$DATETFM^ORWGAPIW($P(VALUES,U,6))
    83         . S NAME=$P(VALUES,U) I '$L(NAME) Q
    84         . S IEN=+$O(@REF@(XREF,NAME,""))
    85         . I DATE,IEN S ARRAY(IEN,DATE)=NAME
    86         K ^TMP("MCAR",$J),^TMP("OR",$J,"MCAR")
    87         Q
    88         ;
    89 MEDVAL(VAL)     ;
    90         N IEN,NAME,NAMES,REF,SEQ,XREF K NAMES,VAL
    91         D FILE^ORWGAPIU(690,.REF,.XREF)
    92         I '$L(REF) Q
    93         I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")"
    94         I $E(REF,$L(REF))="(" S REF=$P(REF,"(")
    95         S NAME=""
    96         F  S NAME=$O(@REF@(XREF,NAME)) Q:NAME=""  D
    97         . S IEN=0
    98         . F  S IEN=$O(@REF@(XREF,NAME,IEN)) Q:IEN<1  D
    99         .. S NAMES(IEN)=NAME
    100         S SEQ=0
    101         S IEN=0
    102         F  S IEN=$O(NAMES(IEN)) Q:IEN<1  D
    103         . S SEQ=SEQ+1
    104         . S VAL(SEQ)=690_U_IEN_U_NAMES(IEN)
    105         Q
    106         ;
    107 MH(ORVALUE,NODE,VALUES) ; from ORWGAPI4
    108         D ENDAS^YTAPI10(.ORVALUE,NODE)
    109         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    110         Q
    111         ;
    112 NOTEX(DFN)      ; $$(dfn) -> 1 if patient has data else 0
    113         Q $$HASDOCMT^TIULX($G(DFN))
    114         ;
    115 OITEM(DATA)     ; API - get order display groups   -  from ORWGAPI
    116         N CNT,IEN,RESULT,TMP,ZERO
    117         D RETURN^ORWGAPIW(.TMP,.DATA)
    118         S CNT=0
    119         S IEN=0
    120         F  S IEN=$O(^ORD(100.98,IEN)) Q:IEN<1  D
    121         . S ZERO=$G(^ORD(100.98,IEN,0)) I '$L(ZERO) Q
    122         . S RESULT="100.98^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,3)
    123         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    124         Q
    125         ;
    126 POV(NODE,ORVALUE,VALUES)        ; from ORWGAPI4
    127         D VPOV^PXPXRM(NODE,.ORVALUE)
    128         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    129         Q
    130         ;
    131 PROB(GMPLLEX,GMPLSTAT,GMPLICD,GMPLODAT,GMPLXDAT,NODE)   ; from ORWGAPI4
    132         N GMPLPNAM,GMPLDLM,GMPLTXT,GMPLCOND,GMPLPRV,GMPLPRIO
    133         D CALL2^GMPLUTL3(NODE)
    134         Q
    135         ;
    136 PTF(NODE,ORVALUE,VALUES)        ; from ORWGAPI3, ORWGAPI4
    137         D PTF^DGPTPXRM(NODE,.ORVALUE)
    138         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    139         Q
    140         ;
    141 RAD(NODE,ORVALUE,VALUES)        ; from ORWGAPI3
    142         D EN1^RAPXRM(NODE,.ORVALUE)
    143         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    144         Q
    145         ;
    146 SKIN(NODE,ORVALUE,VALUES)       ; from ORWGAPI4
    147         D VSKIN^PXPXRM(NODE,.ORVALUE)
    148         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    149         Q
    150         ;
    151 SURG(ORSURG,DFN,VALUES) ; from ORWGAPI2, ORWGAPI4
    152         D GET^SROGTSR(.ORSURG,DFN)
    153         S VALUES=$$DATA^ORWGAPIW(.ORSURG) ;*****************************
    154         Q
    155         ;
    156 SURGX(DFN)      ; $$(dfn) -> 1 if patient has data else 0
    157         Q $O(^SRF("B",+$G(DFN),0))>0
    158         ;
    159 TAX(IEN)        ; $$(ien) -> external display of reminder taxonomy
    160         Q $P($G(^PXD(811.2,+$G(IEN),0)),U)
    161         ;
    162 TITLE(DOCTYPE)  ; $$(document type) -> parent ien^parent^parent abbrev
    163         N IEN,RESULTS K RESULTS
    164         S DOCTYPE=+$G(^TIU(8925,+$G(DOCTYPE),0))
    165         S IEN=+$$DOCCLASS^TIULC1(DOCTYPE) I 'IEN Q ""
    166         D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN)
    167         I '$L($G(RESULTS(.01))) Q ""
    168         Q IEN_U_"note - "_RESULTS(.01)_U_$G(RESULTS(.02))
    169         ;
    170 TIU(ORVALUE,DOCIEN,ONE,DFN,OLDEST,NEWEST)       ; from ORWGAPI1, ORWGAPI3
    171         D CONTEXT^TIUSRVLO(.ORVALUE,DOCIEN,ONE,DFN,$G(OLDEST),$G(NEWEST))
    172         Q
    173         ;
    174 TIUTITLE(DATA)  ; API - get tiu document titles   - from ORWGAPI
    175         N CNT,IEN,RESULT,RESULTS,TMP K ^TMP("TIUTLS",$J)
    176         D RETURN^ORWGAPIW(.TMP,.DATA)
    177         S CNT=0
    178         D TITLIENS^TIULX
    179         S IEN=0
    180         F  S IEN=$O(^TMP("TIUTLS",$J,IEN)) Q:IEN<1  D
    181         . K RESULTS
    182         . D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN)
    183         . I '$L($G(RESULTS(.01))) Q
    184         . S RESULT="8925.1^"_IEN_U_RESULTS(.01)_U_$G(RESULTS(.02))
    185         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    186         K ^TMP("TIUTLS",$J)
    187         Q
    188         ;
    189 VISITX(DFN)     ; $$(dfn) -> 1 if patient has data else 0
    190         Q $O(^AUPNVSIT("AET",+$G(DFN),0))>0
    191         ;
    192 VITAL(ORVALUE,NODE,VALUES)      ; from ORWGAPI4
    193         D EN^GMVPXRM(.ORVALUE,NODE)
    194         S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;*****************************
    195         Q
    196         ;
     1ORWGAPIA ; SLC/STAFF - Graph Application Calls ;11/1/06  12:49
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,251,260**;Dec 17, 1997;Build 26
     3 ;
     4AA(IEN) ; $$(ien) -> external display of accession area
     5 Q $P($G(^LRO(68,IEN,0)),U)
     6AALAB(TEST) ; $$(lab test) -> accession ien^acc name^acc abbrev
     7 N AA,DIV
     8 S TEST=+$G(TEST)
     9 S DIV=+$G(DUZ(2))
     10 S AA=+$P($G(^LAB(60,+TEST,8,DIV,0)),U,2)
     11 I AA Q AA_U_$$ACCLAB(AA)
     12 S AA=+$P($G(^LAB(60,+TEST,8,+$O(^LAB(60,+TEST,8,0)),0)),U,2)
     13 I AA Q AA_U_$$ACCLAB(AA)
     14 Q ""
     15ACC(DATA) ; API - get accession areas   - from ORWGAPI
     16 N CNT,IEN,TMP,RESULT,ZERO
     17 D RETURN^ORWGAPIU(.TMP,.DATA)
     18 S CNT=0
     19 S IEN=0
     20 F  S IEN=$O(^LRO(68,IEN)) Q:IEN<1  D
     21 . S ZERO=$G(^LRO(68,IEN,0)) I '$L(ZERO) Q
     22 . S RESULT="68^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,11)
     23 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     24 Q
     25ACCLAB(AA) ; $$(accession ien) -> acc name^acc abbrev
     26 N ZERO
     27 S ZERO=$G(^LRO(68,AA,0)) I '$L(ZERO) Q ""
     28 Q "lab - "_$P(ZERO,U)_U_$P(ZERO,U,11)
     29ADDDRUG(NUM1) ; $$(additive) -> drug in 50 else ""
     30 N RESULT K ^TMP($J,"RX")
     31 I '$G(IEN) Q ""
     32 D ZERO^PSS52P6(IEN,,,"RX")
     33 S RESULT=$P($G(^TMP($J,"RX",IEN,1)),U)
     34 K ^TMP($J,"RX")
     35 Q RESULT
     36ALLG(IEN) ; $$(ien) -> external display of allergies
     37 I IEN Q $P($G(^GMRD(120.83,IEN,0)),U) ; this is for rxn, allergy is free text
     38 Q IEN
     39CPT(NODE,ORVALUE) ; from ORWGAPI4
     40 D VCPT^PXPXRM(NODE,.ORVALUE)
     41 Q
     42DC(IEN) ; $$(ien) -> external display of drug class
     43 N RESULT K ^TMP($J,"RX")
     44 I '$G(IEN) Q ""
     45 D IEN^PSN50P65(IEN,,"RX")
     46 S RESULT=$G(^TMP($J,"RX",IEN,1))
     47 K ^TMP($J,"RX")
     48 Q RESULT
     49DISCH(IEN) ; $$(pt movement ien) -> discharge date
     50 Q $P($G(^DGPM(+$P($G(^DGPM(+$G(IEN),0)),U,17),0)),U)
     51DOCCLASS(DOCTYPE) ; $$(doc type) -> ien of tiu doc class
     52 N CONSULTS
     53 S DOCTYPE=$E(DOCTYPE,1)
     54 I DOCTYPE="P" Q 3
     55 I DOCTYPE="D" Q 244
     56 I DOCTYPE="C" D CNSLCLAS^TIUSRVD(.CONSULTS) Q CONSULTS
     57 Q 0
     58DRGCLASS(DRUG) ; $$(drug) -> drug class^classification
     59 N RESULT K ^TMP($J,"RX")
     60 I '$G(DRUG) Q ""
     61 D DATA^PSS50(DRUG,,,,,"RX")
     62 S RESULT=+$G(^TMP($J,"RX",DRUG,25))
     63 K ^TMP($J,"RX")
     64 Q RESULT_U_"drug - "_$$DC(RESULT)
     65DRUG(NUM) ; $$(bcma entry) -> drug in 50 else ""
     66 N DONE,DRUG,NUM1
     67 S DONE=0,NUM=+$G(NUM)
     68 S NUM1=0
     69 F  S NUM1=$O(^PSB(53.79,NUM,.5,"B",NUM1)) Q:NUM1<1  S DONE=1 Q
     70 I DONE Q NUM1
     71 S DRUG=0
     72 S NUM1=0
     73 F  S NUM1=$O(^PSB(53.79,NUM,.6,"B",NUM1)) Q:NUM1<1  D  I DONE Q
     74 . S DRUG=$$ADDDRUG(NUM1)
     75 . I DRUG S DONE=1
     76 I DONE Q DRUG
     77 S DRUG=0
     78 S NUM1=0
     79 F  S NUM1=$O(^PSB(53.79,NUM,.7,"B",NUM1)) Q:NUM1<1  D  I DONE Q
     80 . S DRUG=$$SOLDRUG(NUM1)
     81 . I DRUG S DONE=1
     82 I DONE Q DRUG
     83 Q ""
     84DRUGC(VALUES) ; API - get drug classes   - from ORWGAPI
     85 N CLASS,IEN,NUM,ROOT K VALUES
     86 S NUM=0
     87 S ROOT=$$ROOT^PSN50P65(1)
     88 S CLASS=""
     89 F  S CLASS=$O(@ROOT@(CLASS)) Q:CLASS=""  D
     90 . S IEN=0
     91 . F  S IEN=$O(@ROOT@(CLASS,IEN)) Q:IEN=""  D
     92 .. S NUM=NUM+1
     93 .. S VALUES(NUM)="50.605^"_IEN_U_CLASS
     94 M ^TMP("ORWGRPC",$J)=VALUES K VALUES
     95 Q
     96EDU(NODE,ORVALUE) ; from ORWGAPI4
     97 D VPEDU^PXPXRM(NODE,.ORVALUE)
     98 Q
     99EXAM(NODE,ORVALUE) ; from ORWGAPI4
     100 D VXAM^PXPXRM(NODE,.ORVALUE)
     101 Q
     102GETTIU(ORDATA,IEN) ; from ORWGAPID
     103 D TGET^TIUSRVR1(.ORDATA,IEN)
     104 Q
     105HF(NODE,ORVALUE) ; from ORWGAPI4
     106 D VHF^PXPXRM(NODE,.ORVALUE)
     107 Q
     108ICD0(IEN) ; $$(ien) -> external display of IDC0
     109 Q $P($G(^ICD0(IEN,0)),U)_" "_$P($G(^ICD0(IEN,0)),U,4)
     110ICD9(IEN) ; $$(ien) -> external display of IDC9
     111 Q $P($G(^ICD9(IEN,0)),U)_" "_$P($G(^ICD9(IEN,0)),U,3)
     112ICPT(IEN,CSD) ; $$(ien) -> external display of CPT
     113 N X S X=$$CPT^ICPTCOD($G(IEN),$G(CSD))
     114 Q $P(X,U,2)_" "_$E($P(X,U,3),1,30)
     115IMM(NODE,ORVALUE) ; from ORWGAPI4
     116 D VIMM^PXPXRM(NODE,.ORVALUE)
     117 Q
     118INSIG(NODE) ; $$(node) -> sig
     119 N DFN,DNUM,IEN,LNUM,SIG,SUB ; replace this code in v27 with INSIG^ORWGAPIX
     120 S DFN=+$G(NODE)
     121 S SUB=$P($G(NODE),";",2)
     122 S IEN=+$P($G(NODE),";",3)
     123 S SIG=""
     124 I SUB=5 D
     125 . S LNUM=$G(^PS(55,DFN,5,IEN,0))
     126 . S DNUM=$G(^PS(55,DFN,5,IEN,.2))
     127 . I $L(DNUM),$L(LNUM) D
     128 .. S SIG="  Give: "_$$EXT^ORWGAPIX($P(LNUM,U,3),55.06,3)
     129 .. S SIG=SIG_" "_$$EXT^ORWGAPIX($P(LNUM,U,7),55.06,7)
     130 I SUB="IV" D
     131 . S LNUM=$G(^PS(55,DFN,"IV",IEN,0))
     132 . S DNUM=$G(^PS(55,DFN,"IV",IEN,.2))
     133 . I $L(DNUM),$L(LNUM) D
     134 .. S SIG="  Give: "_$P(DNUM,U,2)
     135 .. S SIG=SIG_" "_$$EXT^ORWGAPIX($P(LNUM,U,2),55.01,.02)_" "_$P(LNUM,U,9)
     136 Q SIG
     137ISA(USER,CLASS,ORERR) ; $$(user,user class,err) -> 1 if user in class, else 0
     138 Q $$ISA^USRLM(USER,CLASS,.ORERR)
     139LAB(ORVALUE,NODE,ITEM) ; from ORWGAPI3
     140 D LRPXRM^LRPXAPI(.ORVALUE,NODE,ITEM,"VSC")
     141 Q
     142LABNAME(Y) ; $$(item ien) -> item name
     143 I $P(Y,";")="A",$P(Y,";",2)="S" Q $P(Y,".",2,99)
     144 Q $$ITEMNM^LRPXAPIU(Y)
     145LABSUM(ORDATA,DFN,DATE1,DATE2,ORSUB) ; from ORWGAPID
     146 D EN^LR7OSUM(.ORDATA,DFN,DATE1,DATE2,,80,.ORSUB)
     147 Q
     148LOS(DGPMIFN) ; $$(pt movement ien) -> length of stay
     149 N X D ^DGPMLOS
     150 Q +$P($G(X),U,5)
     151LRDFN(DFN) ; $$(dfn) -> lrdfn
     152 Q $$LRDFN^LRPXAPIU(DFN)
     153LRIDT(LRDT) ;  $$(date) -> inverse date
     154 Q $$LRIDT^LRPXAPIU(LRDT)
     155MEDICINE(ARRAY,DFN) ;
     156 N DATE,FILE,IEN,NAME,NUM,REF,VALUES,XREF
     157 K ARRAY,^TMP("MCAR",$J),^TMP("OR",$J,"MCAR")
     158 D FILE^ORWGAPIU(690,.REF,.XREF)
     159 I '$L(REF) Q
     160 I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")"
     161 I $E(REF,$L(REF))="(" S REF=$P(REF,"(")
     162 D EN^MCARPS2(DFN)
     163 S NUM=0
     164 F  S NUM=$O(^TMP("OR",$J,"MCAR","OT",NUM)) Q:NUM<1  D
     165 . S VALUES=^TMP("OR",$J,"MCAR","OT",NUM)
     166 . S DATE=$$DATETFM^ORWGAPIU($P(VALUES,U,6))
     167 . S NAME=$P(VALUES,U) I '$L(NAME) Q
     168 . S IEN=+$O(@REF@(XREF,NAME,""))
     169 . I DATE,IEN S ARRAY(IEN,DATE)=NAME
     170 K ^TMP("MCAR",$J),^TMP("OR",$J,"MCAR")
     171 Q
     172MEDVAL(VAL) ;
     173 N IEN,NAME,NAMES,REF,SEQ,XREF K NAMES,VAL
     174 D FILE^ORWGAPIU(690,.REF,.XREF)
     175 I '$L(REF) Q
     176 I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")"
     177 I $E(REF,$L(REF))="(" S REF=$P(REF,"(")
     178 S NAME=""
     179 F  S NAME=$O(@REF@(XREF,NAME)) Q:NAME=""  D
     180 . S IEN=0
     181 . F  S IEN=$O(@REF@(XREF,NAME,IEN)) Q:IEN<1  D
     182 .. S NAMES(IEN)=NAME
     183 S SEQ=0
     184 S IEN=0
     185 F  S IEN=$O(NAMES(IEN)) Q:IEN<1  D
     186 . S SEQ=SEQ+1
     187 . S VAL(SEQ)=690_U_IEN_U_NAMES(IEN)
     188 Q
     189MH(ORVALUE,NODE) ; from ORWGAPI4
     190 D ENDAS^YTAPI10(.ORVALUE,NODE)
     191 Q
     192NVASIG(NODE) ;  $$(node) -> sig on non-va drug
     193 N RESULTS,SIG K RESULTS
     194 I '$L(NODE) Q ""
     195 D RXNVA(NODE,.RESULTS)
     196 S SIG=RESULTS("DOSAGE")
     197 S SIG=SIG_" "_RESULTS("MEDICATION ROUTE")
     198 S SIG=SIG_" "_RESULTS("SCHEDULE")
     199 Q SIG
     200OITEM(DATA) ; API - get order display groups   -  from ORWGAPI
     201 N CNT,IEN,RESULT,TMP,ZERO
     202 D RETURN^ORWGAPIU(.TMP,.DATA)
     203 S CNT=0
     204 S IEN=0
     205 F  S IEN=$O(^ORD(100.98,IEN)) Q:IEN<1  D
     206 . S ZERO=$G(^ORD(100.98,IEN,0)) I '$L(ZERO) Q
     207 . S RESULT="100.98^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,3)
     208 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     209 Q
     210POINAME(IEN) ; $$(poi entry) - > name and dosage form else ""
     211 N NAME,RESULT K ^TMP($J,"RX")
     212 I '$G(IEN) Q ""
     213 D ZERO^PSS50P7(IEN,,,"RX")
     214 S NAME=$P($G(^TMP($J,"RX",IEN,.01)),U)
     215 S NAME=NAME_" "_$P($G(^TMP($J,"BOB",IEN,.02)),U,2)
     216 K ^TMP($J,"RX")
     217 I NAME'=" " Q NAME
     218 Q ""
     219POV(NODE,ORVALUE) ; from ORWGAPI4
     220 D VPOV^PXPXRM(NODE,.ORVALUE)
     221 Q
     222PROB(GMPLLEX,GMPLSTAT,GMPLICD,GMPLODAT,GMPLXDAT,NODE) ; from ORWGAPI4
     223 N GMPLPNAM,GMPLDLM,GMPLTXT,GMPLCOND,GMPLPRV,GMPLPRIO
     224 D CALL2^GMPLUTL3(NODE)
     225 Q
     226PTF(NODE,ORVALUE) ; from ORWGAPI3, ORWGAPI4
     227 D PTF^DGPTPXRM(NODE,.ORVALUE)
     228 Q
     229RAD(NODE,ORVALUE) ; from ORWGAPI3
     230 D EN1^RAPXRM(NODE,.ORVALUE)
     231 Q
     232RXIN(NODE,ORVALUE) ; from ORWGAPI3
     233 D OEL^PSJPXRM1(NODE,.ORVALUE)
     234 Q
     235RXNVA(NODE,ORVALUE,XSTART,XSTOP) ; from ORWGAPI1, ORWGAPI3, ORWGAPID
     236 S XSTART=1,XSTOP=1
     237 D NVA^PSOPXRM1(NODE,.ORVALUE)
     238 I '$G(ORVALUE("START DATE")) D
     239 . S ORVALUE("START DATE")=$G(ORVALUE("DOCUMENTED DATE"))
     240 . S XSTART=0
     241 I '$G(ORVALUE("DISCONTINUED DATE")) D
     242 . S XSTOP=0
     243 Q
     244RXOUT(NODE,ORVALUE) ; from ORWGAPI3
     245 D PSRX^PSOPXRM1(NODE,.ORVALUE)
     246 Q
     247SIG(DFN,RXIEN) ; $$(dfn,prescription ien) -> sig
     248 N LNUM,SIG K ^TMP($J,"RX")
     249 S RXIEN=+$G(RXIEN)
     250 D RX^PSO52API(DFN,"RX",RXIEN,,"M",,)
     251 S SIG=""
     252 S LNUM=0
     253 F  S LNUM=$O(^TMP($J,"RX",DFN,RXIEN,"M",LNUM)) Q:LNUM<1  D
     254 . S SIG=SIG_$G(^TMP($J,"RX",DFN,RXIEN,"M",LNUM,0))_" "
     255 I $L(SIG) S SIG="  Sig: "_$$LOW^ORWGAPIX(SIG)
     256 K ^TMP($J,"RX")
     257 Q SIG
     258SKIN(NODE,ORVALUE) ; from ORWGAPI4
     259 D VSKIN^PXPXRM(NODE,.ORVALUE)
     260 Q
     261SOLDRUG(NUM1) ; $$(iv solution) -> drug in 50 else ""
     262 N RESULT K ^TMP($J,"RX")
     263 I '$G(IEN) Q ""
     264 D ZERO^PSS52P7(IEN,,,"RX")
     265 S RESULT=$P($G(^TMP($J,"RX",IEN,1)),U)
     266 K ^TMP($J,"RX")
     267 Q RESULT
     268SURG(ORSURG,DFN) ; from ORWGAPI2, ORWGAPI4
     269 D GET^SROGTSR(.ORSURG,DFN)
     270 Q
     271TAX(IEN) ; $$(ien) -> external display of reminder taxonomy
     272 Q $P($G(^PXD(811.2,+$G(IEN),0)),U)
     273TITLE(DOCTYPE) ; $$(document type) -> parent ien^parent^parent abbrev
     274 N IEN,RESULTS K RESULTS
     275 S DOCTYPE=+$G(^TIU(8925,+$G(DOCTYPE),0))
     276 S IEN=+$$DOCCLASS^TIULC1(DOCTYPE) I 'IEN Q ""
     277 D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN)
     278 I '$L($G(RESULTS(.01))) Q ""
     279 Q IEN_U_"note - "_RESULTS(.01)_U_$G(RESULTS(.02))
     280TIU(ORVALUE,DOCIEN,ONE,DFN,OLDEST,NEWEST) ; from ORWGAPI1, ORWGAPI3
     281 D CONTEXT^TIUSRVLO(.ORVALUE,DOCIEN,ONE,DFN,$G(OLDEST),$G(NEWEST))
     282 Q
     283TIUTITLE(DATA) ; API - get tiu document titles   - from ORWGAPI
     284 N CNT,IEN,RESULT,RESULTS,TMP
     285 D RETURN^ORWGAPIU(.TMP,.DATA)
     286 S CNT=0
     287 S IEN=0
     288 F  S IEN=$O(^TIU(8925.1,IEN)) Q:IEN<1  D
     289 . I $P($G(^TIU(8925.1,IEN,0)),U,4)'="DOC" Q
     290 . K RESULTS
     291 . D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN)
     292 . I '$L($G(RESULTS(.01))) Q
     293 . S RESULT="8925.1^"_IEN_U_RESULTS(.01)_U_$G(RESULTS(.02))
     294 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     295 Q
     296VITAL(ORVALUE,NODE) ; from ORWGAPI4
     297 D EN^GMVPXRM(.ORVALUE,NODE)
     298 Q
     299 ; $$(dfn) -> 1 if patient has data else 0
     300ADMITX(DFN) ;
     301 Q $O(^DGPM("C",+$G(DFN),0))>0
     302ALLERGYX(DFN) ;
     303 Q $O(^GMR(120.8,"B",+$G(DFN),0))>0
     304BCMAX(DFN) ;
     305 Q $O(^PSB(53.79,"B",+$G(DFN),0))>0
     306NOTEX(DFN) ;
     307 Q $O(^TIU(8925,"C",+$G(DFN),0))>0
     308NVAX(DFN) ;
     309 Q $L($O(^PXRMINDX("55NVA","PI",+$G(DFN),"")))>0
     310SURGX(DFN) ;
     311 Q $O(^SRF("B",+$G(DFN),0))>0
     312TREATX(DFN) ;
     313 Q $L($O(^AUPNVTRT("AA",+$G(DFN),"")))>0
     314VISITX(DFN) ;
     315 Q $O(^AUPNVSIT("AET",+$G(DFN),0))>0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIB.m

    r613 r623  
    1 ORWGAPIB        ; SLC/STAFF - Graph Blood Bank ;12/21/05  08:21
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4 BBITEM(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)     ; from ORWGAPIR
    5         N DATE,IDATE,INEWEST,IOLDEST,ITEM,LRDFN,OK,RESULT
    6         K ^TMP("ORWGRPC TEMP",$J)
    7         S INEWEST=$$LRIDT^ORWGAPIC(NEWEST),IOLDEST=$$LRIDT^ORWGAPIC(OLDEST)
    8         S LRDFN=$$LRDFN^ORWGAPIC(DFN)
    9         S IDATE=0
    10         F  S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE<1  D
    11         . S ITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2)
    12         . I 'ITEM Q
    13         . S OK=0
    14         . I FMT=6 D
    15         .. Q:IDATE<INEWEST  Q:IDATE>IOLDEST
    16         .. S OK=1
    17         .. S CNT=CNT+1
    18         .. S RESULT="63BB"_U_ITEM
    19         . I FMT=3 D
    20         .. I '$D(^TMP("ORWGRPC TEMP",$J,ITEM)) D
    21         ... S OK=1
    22         ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
    23         ... S DATE=$$LRIDT^ORWGAPIC(IDATE)
    24         ... S CNT=CNT+1
    25         ... S RESULT="63BB^"_ITEM_"^^"_$P($G(^LAB(66,ITEM,0)),U)_"^^"_DATE
    26         . I FMT=0 D
    27         .. S OK=1
    28         .. S CNT=CNT+1
    29         .. S RESULT="63BB^"_ITEM_U_$P($G(^LAB(66,ITEM,0)),U)
    30         . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    31         K ^TMP("ORWGRPC TEMP",$J)
    32         Q
    33         ;
    34 BBDATA(DATA,ITEM,START,DFN,CNT,TMP,BACKTO)      ; from ORWGAPIR
    35         N DATE,IDATE,LRDFN,NITEM,RESULT
    36         S LRDFN=$$LRDFN^ORWGAPIC(DFN)
    37         S IDATE="",CNT=$G(CNT),BACKTO=+$G(BACKTO)
    38         F  S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE=""  D
    39         . S NITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2)
    40         . I NITEM'=ITEM Q
    41         . S DATE=$$LRIDT^ORWGAPIC(IDATE)
    42         . I DATE>START Q
    43         . I DATE<BACKTO Q
    44         . S RESULT="63BB^"_ITEM_U_DATE_U
    45         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    46         Q
    47         ;
    48 BBX(DFN)        ; $$(dfn) -> 1 if patient has blood bank data ,else 0
    49         Q $L($O(^LR(+$$LRDFN^ORWGAPIC($G(DFN)),1.6,"")))>0
    50         ;
     1ORWGAPIB ; SLC/STAFF - Graph Blood Bank ;12/21/05  08:21
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4BBITEM(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     5 N DATE,IDATE,INEWEST,IOLDEST,ITEM,LRDFN,OK,RESULT
     6 K ^TMP("ORWGRPC TEMP",$J)
     7 S INEWEST=$$LRIDT^ORWGAPIA(NEWEST),IOLDEST=$$LRIDT^ORWGAPIA(OLDEST)
     8 S LRDFN=$$LRDFN^ORWGAPIA(DFN)
     9 S IDATE=0
     10 F  S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE<1  D
     11 . S ITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2)
     12 . I 'ITEM Q
     13 . S OK=0
     14 . I FMT=6 D
     15 .. Q:IDATE<INEWEST  Q:IDATE>IOLDEST
     16 .. S OK=1
     17 .. S CNT=CNT+1
     18 .. S RESULT="63BB"_U_ITEM
     19 . I FMT=3 D
     20 .. I '$D(^TMP("ORWGRPC TEMP",$J,ITEM)) D
     21 ... S OK=1
     22 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)=""
     23 ... S DATE=$$LRIDT^ORWGAPIA(IDATE)
     24 ... S CNT=CNT+1
     25 ... S RESULT="63BB^"_ITEM_"^^"_$P($G(^LAB(66,ITEM,0)),U)_"^^"_DATE
     26 . I FMT=0 D
     27 .. S OK=1
     28 .. S CNT=CNT+1
     29 .. S RESULT="63BB^"_ITEM_U_$P($G(^LAB(66,ITEM,0)),U)
     30 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     31 K ^TMP("ORWGRPC TEMP",$J)
     32 Q
     33 ;
     34BBDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     35 N DATE,IDATE,LRDFN,NITEM,RESULT
     36 S LRDFN=$$LRDFN^ORWGAPIA(DFN)
     37 S IDATE="",CNT=$G(CNT)
     38 F  S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE=""  D
     39 . S NITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2)
     40 . I NITEM'=ITEM Q
     41 . S DATE=$$LRIDT^ORWGAPIA(IDATE)
     42 . I DATE>START Q
     43 . S RESULT="63BB^"_ITEM_U_DATE_U
     44 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     45 Q
     46 ;
     47BBX(DFN) ; $$(dfn) -> 1 if patient has blood bank data ,else 0
     48 Q $L($O(^LR(+$$LRDFN^ORWGAPIA($G(DFN)),1.6,"")))>0
     49 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPID.m

    r613 r623  
    1 ORWGAPID        ; SLC/STAFF - Graph API Details ;12/21/05  08:19
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4 DETAILS(DATA,DFN,DATE1,DATE2,FILEITEM)  ; from ORWGAPI (series click)
    5         N ITEM,FILE,SUBHEAD,TYPEITEM K SUBHEAD,TYPEITEM
    6         K ^TMP("LR7OGX",$J),^TMP("LRC",$J)
    7         K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J)
    8         S FILE=$P(FILEITEM,U)
    9         S ITEM=$$UP^ORWGAPIX($P(FILEITEM,U,2))
    10         I '$L(ITEM) Q
    11         D
    12         . I FILE=63 D  Q
    13         .. D INTERIM^ORWLRR(.DATA,DFN,DATE1,DATE2)
    14         .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT")
    15         . I FILE="63MI" D  Q
    16         .. D MICRO^ORWLRR(.DATA,DFN,DATE1,DATE2)
    17         .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT")
    18         . I FILE="63AP" D   Q
    19         .. S SUBHEAD("CYTOPATHOLOGY")=""
    20         .. S SUBHEAD("SURGICAL PATHOLOGY")=""
    21         .. S SUBHEAD("EM")=""
    22         .. S SUBHEAD("AUTOPSY")=""
    23         .. D LABSUM^ORWGAPIC(.DATA,DFN,DATE1,DATE2,.SUBHEAD)
    24         .. M ^TMP("ORWGRPC",$J)=^TMP("LRC",$J)
    25         . I FILE="63BB" D  Q
    26         .. D BLR^ORWRP1(.DATA,DFN,"",DATE1,DATE2)
    27         .. M ^TMP("ORWGRPC",$J)=^TMP("ORLRC",$J)
    28         . I FILE="53.79" D  Q
    29         .. ;D BCMA1^ORWRP1A(.DATA,DFN,"",DATE1,DATE2) ***** BA 12/14/07
    30         .. D BCMA1^ORWRP1A(.DATA,DFN,"",DATE2,DATE1)
    31         .. M ^TMP("ORWGRPC",$J)=^TMP("PSBO",$J)
    32         . I FILE="8925" D  Q
    33         .. D NOTE(.DATA,DFN,DATE1,DATE2,ITEM)
    34         .. ;M ^TMP("ORWGRPC",$J)=^TMP("TIUVIEW",$J)
    35         . S TYPEITEM(1)=FILE_"^0"
    36         . D DETAIL(.DATA,DFN,DATE1,DATE2,.TYPEITEM)
    37         K ^TMP("LR7OGX",$J),^TMP("LRC",$J)
    38         K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J)
    39         Q
    40         ;
    41 DETAIL(DATA,DFN,DATE1,DATE2,TYPEITEM)   ; from ORWGAPI (legend click)
    42         N CNT,FILE,GMTSPX1,GMTSPX2,ITEM,TITEMS,TYPE
    43         N COMP,NEWITEMS K COMP,NEWITEMS
    44         K ^TMP("ORDATA",$J)
    45         S DFN=+$G(DFN) I 'DFN Q
    46         I '$L($O(TYPEITEM(0))) Q
    47         S TYPE=""
    48         F  S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE=""  D
    49         . S TITEMS=TYPEITEM(TYPE)
    50         . S FILE=$P(TITEMS,U) I '$L(FILE) Q
    51         . S ITEM=$P(TITEMS,U,2) I '$L(ITEM) Q
    52         . S NEWITEMS(FILE,ITEM)=""
    53         S CNT=0
    54         S FILE=""
    55         F  S FILE=$O(NEWITEMS(FILE)) Q:FILE=""  D
    56         . S CNT=CNT+1
    57         . S COMP(CNT)=$$COMPTYPE^ORWGAPIT(FILE)
    58         S GMTSPX1=DATE1,GMTSPX2=DATE2
    59         D REPORT^ORWRP2(.DATA,.COMP,DFN)
    60         M ^TMP("ORWGRPC",$J)=^TMP("ORDATA",$J)
    61         ;K ^TMP("ORDATA",$J)
    62         ;Q
    63         ;
    64         S CNT=0
    65         S TYPE=""
    66         F  S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE=""  D
    67         . S TITEMS=TYPEITEM(TYPE)
    68         . S CNT=CNT+1
    69         . S ^TMP("ORWGRPC",$J,CNT/10000)="~~~^"_TITEMS
    70         ;
    71         K ^TMP("ORDATA",$J)
    72         Q
    73         ;
    74 GETDATES(DATA,REPORTID) ; from ORWGAPI
    75         N DAT,TMP K DAT
    76         D RETURN^ORWGAPIW(.TMP,.DATA)
    77         S DAT(1)="S^Date Range..."
    78         S DAT(2)="1^Today"
    79         S DAT(3)="2^One Week"
    80         S DAT(4)="3^Two Weeks"
    81         S DAT(5)="4^One Month"
    82         S DAT(6)="5^Six Months"
    83         S DAT(7)="6^One Year"
    84         S DAT(8)="7^Two Years"
    85         S DAT(9)="8^All Results"
    86         D DATES^ORWGAPIP(.DAT,REPORTID)
    87         I TMP M ^TMP(DATA,$J)=DAT
    88         I 'TMP M DATA=DAT
    89         Q
    90         ;
    91 NOTE(DATA,DFN,DATE1,DATE2,ITEM) ;
    92         N CNT,DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,LINE,NUM,RESULTS K DUM
    93         K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J)
    94         S CNT=$G(CNT)
    95         F DOCTYPE="P","D","C" D
    96         . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
    97         . K ^TMP("TIUR",$J)
    98         . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN,DATE1,DATE2)
    99         . S DOC=0
    100         . F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
    101         .. S RESULTS=^TMP("TIUR",$J,DOC)
    102         .. S IEN=+$P(RESULTS,U)
    103         .. K ^TMP("TIUVIEW",$J)
    104         .. D GETTIU^ORWGAPIA(.DATA,IEN)
    105         .. S NUM=0
    106         .. F  S NUM=$O(^TMP("TIUVIEW",$J,NUM)) Q:NUM<1  D
    107         ... S LINE=$G(^TMP("TIUVIEW",$J,NUM))
    108         ... S CNT=CNT+1
    109         ... S ^TMP("ORWGRPC",$J,CNT)=LINE
    110         .. I CNT>1 D
    111         ... S CNT=CNT+1
    112         ... S ^TMP("ORWGRPC",$J,CNT)=" "
    113         ... S CNT=CNT+1
    114         ... S ^TMP("ORWGRPC",$J,CNT)=" "
    115         ... S ^TMP("ORWGRPC",$J,CNT/10000)="~~~^"_^TMP("TIUR",$J,DOC)
    116         K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J)
    117         Q
    118         ;
    119 TAX(DATA,ALL,REMTAX)    ; from ORWGAPI
    120         N CNT,REM,CODE,NUM,TMP
    121         K ^TMP("ORWG TEMP",$J)
    122         D RETURN^ORWGAPIW(.TMP,.DATA)
    123         S CNT=0
    124         S REM=0
    125         I ALL F  S REM=$O(^PXD(811.2,REM)) Q:REM<1  D TEMP(REM)
    126         I 'ALL D
    127         . S NUM=0
    128         . F  S NUM=$O(REMTAX(NUM)) Q:NUM<1  D
    129         .. S REM=REMTAX(NUM)
    130         .. D TEMP(REM)
    131         S CODE=""
    132         F  S CODE=$O(^TMP("ORWG TEMP",$J,CODE)) Q:CODE=""  D
    133         . D SETUP^ORWGAPIW(.DATA,CODE,TMP,.CNT)
    134         K ^TMP("ORWG TEMP",$J)
    135         Q
    136         ;
    137 TEMP(REM)       ;
    138         N NODE,NUM,SUB
    139         I $P($G(^PXD(811.2,REM,0)),U,6)=1 Q
    140         F SUB=80,80.1,81 D
    141         . S NUM=0
    142         . F  S NUM=$O(^PXD(811.3,REM,SUB,NUM)) Q:NUM<1  D
    143         .. S NODE=+$G(^PXD(811.3,REM,SUB,NUM,0))
    144         .. I 'NODE Q
    145         .. I SUB=80 D  Q
    146         ... S ^TMP("ORWG TEMP",$J,"45DX;"_NODE)=""
    147         ... S ^TMP("ORWG TEMP",$J,"9000010.07;"_NODE)=""
    148         ... S ^TMP("ORWG TEMP",$J,"9000011;"_NODE)=""
    149         .. I SUB=80.1 D  Q
    150         ... S ^TMP("ORWG TEMP",$J,"45OP;"_NODE)=""
    151         .. I SUB=81 D  Q
    152         ... S ^TMP("ORWG TEMP",$J,"9000010.18;"_NODE)=""
    153         Q
    154         ;
    155 PLX2(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP)       ; from ORWGAPIR
    156         N DATE,DTONSET,DTPLUS1,DTRESOLV,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE
    157         K ^TMP("ORWGRPC TEMP",$J)
    158         S DTPLUS1=$$FMADD^ORWGAPIX(DT,1)
    159         S STATUS=""
    160         F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
    161         . S PRIORITY=""
    162         . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
    163         .. S ITEM=""
    164         .. F  S ITEM=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM=""  D
    165         ... S DATE=""
    166         ... F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
    167         .... S NODE=""
    168         .... F  S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE=""  D
    169         ..... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE)
    170         ..... I 'DTRESOLV S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTPLUS1 Q
    171         ..... S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTRESOLV
    172         S PROB=""
    173         F  S PROB=$O(^TMP("ORWGRPC TEMP",$J,PROB)) Q:PROB=""  D
    174         . S VALUE=$$EVALUE^ORWGAPIU(PROB,9000011,.01)
    175         . I FMT=0 D
    176         .. S CNT=CNT+1
    177         .. S RESULT=9999911_U_PROB_U_VALUE
    178         .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    179         . I FMT=6 D
    180         .. S OK=0
    181         .. S DATE=0
    182         .. F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    183         ... S DTRESOLV=^TMP("ORWGRPC TEMP",$J,PROB,DATE)
    184         ... I DTRESOLV<OLDEST Q
    185         ... S CNT=CNT+1
    186         ... S OK=1
    187         ... S RESULT=9999911_U_PROB
    188         .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    189         . I FMT=3 D
    190         .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,""),-1)
    191         .. I 'DATE Q
    192         .. S CNT=CNT+1
    193         .. S RESULT=9999911_U_PROB_"^^"_VALUE_"^^"_DATE
    194         .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    195         K ^TMP("ORWGRPC TEMP",$J)
    196         Q
    197         ;
    198 PROBX4(DATA,ITEM,START,DFN,CNT,TMP)     ; from ORWGAPIR
    199         N DATE,DTONSET,DTPLUS1,DTRESOLV,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE
    200         K ^TMP("ORWGRPC TEMP",$J)
    201         S CNT=$G(CNT),DTPLUS1=$$FMADD^ORWGAPIX(DT,1)
    202         S STATUS=""
    203         F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
    204         . S PRIORITY=""
    205         . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
    206         .. S DATE=""
    207         .. F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
    208         ... I DATE>START Q
    209         ... S NODE=""
    210         ... F  S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE=""  D
    211         .... S ^TMP("ORWGRPC TEMP",$J,NODE)=""
    212         S NODE=""
    213         F  S NODE=$O(^TMP("ORWGRPC TEMP",$J,NODE)) Q:NODE=""  D
    214         . D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE)
    215         . I 'DTONSET Q
    216         . I 'DTRESOLV S DTRESOLV=DTPLUS1
    217         . S RESULT=9999911_U_PROBDX_U_DTONSET_U_DTRESOLV_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12)
    218         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    219         K ^TMP("ORWGRPC TEMP",$J)
    220         Q
    221         ;
     1ORWGAPID ; SLC/STAFF - Graph API Details ;12/21/05  08:19
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4DETAILS(DATA,DFN,DATE1,DATE2,FILEITEM) ; from ORWGAPI (series click)
     5 N ITEM,FILE,SUBHEAD,TYPEITEM K SUBHEAD,TYPEITEM
     6 K ^TMP("LR7OGX",$J),^TMP("LRC",$J)
     7 K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J)
     8 S FILE=$P(FILEITEM,U)
     9 S ITEM=$$UP^ORWGAPIX($P(FILEITEM,U,2))
     10 I '$L(ITEM) Q
     11 D
     12 . I FILE=63 D  Q
     13 .. D INTERIM^ORWLRR(.DATA,DFN,DATE1,DATE2)
     14 .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT")
     15 . I FILE="63MI" D  Q
     16 .. D MICRO^ORWLRR(.DATA,DFN,DATE1,DATE2)
     17 .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT")
     18 . I FILE="63AP" D   Q
     19 .. S SUBHEAD("CYTOPATHOLOGY")=""
     20 .. S SUBHEAD("SURGICAL PATHOLOGY")=""
     21 .. S SUBHEAD("EM")=""
     22 .. S SUBHEAD("AUTOPSY")=""
     23 .. D LABSUM^ORWGAPIA(.DATA,DFN,DATE1,DATE2,.SUBHEAD)
     24 .. M ^TMP("ORWGRPC",$J)=^TMP("LRC",$J)
     25 . I FILE="63BB" D  Q
     26 .. D BLR^ORWRP1(.DATA,DFN,"",DATE1,DATE2)
     27 .. M ^TMP("ORWGRPC",$J)=^TMP("ORLRC",$J)
     28 . I FILE="53.79" D  Q
     29 .. D BCMA1^ORWRP1A(.DATA,DFN,"",DATE1,DATE2)
     30 .. M ^TMP("ORWGRPC",$J)=^TMP("PSBO",$J)
     31 . I FILE="8925" D  Q
     32 .. D NOTE(.DATA,DFN,DATE1,DATE2,ITEM)
     33 .. ;M ^TMP("ORWGRPC",$J)=^TMP("TIUVIEW",$J)
     34 . S TYPEITEM(1)=FILE_"^0"
     35 . D DETAIL(.DATA,DFN,DATE1,DATE2,.TYPEITEM)
     36 K ^TMP("LR7OGX",$J),^TMP("LRC",$J)
     37 K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J)
     38 Q
     39 ;
     40DETAIL(DATA,DFN,DATE1,DATE2,TYPEITEM) ; from ORWGAPI (legend click)
     41 N CNT,FILE,GMTSPX1,GMTSPX2,ITEM,TITEMS,TYPE
     42 N COMP,NEWITEMS K COMP,NEWITEMS
     43 K ^TMP("ORDATA",$J)
     44 S DFN=+$G(DFN) I 'DFN Q
     45 I '$L($O(TYPEITEM(0))) Q
     46 S TYPE=""
     47 F  S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE=""  D
     48 . S TITEMS=TYPEITEM(TYPE)
     49 . S FILE=$P(TITEMS,U) I '$L(FILE) Q
     50 . S ITEM=$P(TITEMS,U,2) I '$L(ITEM) Q
     51 . S NEWITEMS(FILE,ITEM)=""
     52 S CNT=0
     53 S FILE=""
     54 F  S FILE=$O(NEWITEMS(FILE)) Q:FILE=""  D
     55 . S CNT=CNT+1
     56 . S COMP(CNT)=$$COMPTYPE^ORWGAPIT(FILE)
     57 S GMTSPX1=DATE1,GMTSPX2=DATE2
     58 D REPORT^ORWRP2(.DATA,.COMP,DFN)
     59 M ^TMP("ORWGRPC",$J)=^TMP("ORDATA",$J)
     60 K ^TMP("ORDATA",$J)
     61 Q
     62 ;
     63NOTE(DATA,DFN,DATE1,DATE2,ITEM) ;
     64 N CNT,DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,LINE,NUM,RESULTS K DUM
     65 K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J)
     66 S CNT=$G(CNT)
     67 F DOCTYPE="P","D","C" D
     68 . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE)
     69 . K ^TMP("TIUR",$J)
     70 . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN,DATE1,DATE2)
     71 . S DOC=0
     72 . F  S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1  D
     73 .. S RESULTS=^TMP("TIUR",$J,DOC)
     74 .. S IEN=+$P(RESULTS,U)
     75 .. K ^TMP("TIUVIEW",$J)
     76 .. D GETTIU^ORWGAPIA(.DATA,IEN)
     77 .. S NUM=0
     78 .. F  S NUM=$O(^TMP("TIUVIEW",$J,NUM)) Q:NUM<1  D
     79 ... S LINE=$G(^TMP("TIUVIEW",$J,NUM))
     80 ... S CNT=CNT+1
     81 ... S ^TMP("ORWGRPC",$J,CNT)=LINE
     82 .. I CNT>1 D
     83 ... S CNT=CNT+1
     84 ... S ^TMP("ORWGRPC",$J,CNT)=" "
     85 ... S CNT=CNT+1
     86 ... S ^TMP("ORWGRPC",$J,CNT)=" "
     87 K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J)
     88 Q
     89 ;
     90TAX(DATA,ALL,REMTAX) ; from ORWGAPI
     91 N CNT,REM,CODE,NUM,TMP
     92 K ^TMP("ORWG TEMP",$J)
     93 D RETURN^ORWGAPIU(.TMP,.DATA)
     94 S CNT=0
     95 S REM=0
     96 I ALL F  S REM=$O(^PXD(811.2,REM)) Q:REM<1  D TEMP(REM)
     97 I 'ALL D
     98 . S NUM=0
     99 . F  S NUM=$O(REMTAX(NUM)) Q:NUM<1  D
     100 .. S REM=REMTAX(NUM)
     101 .. D TEMP(REM)
     102 S CODE=""
     103 F  S CODE=$O(^TMP("ORWG TEMP",$J,CODE)) Q:CODE=""  D
     104 . D SETUP^ORWGAPIU(.DATA,CODE,TMP,.CNT)
     105 K ^TMP("ORWG TEMP",$J)
     106 Q
     107 ;
     108TEMP(REM) ;
     109 N NODE,NUM,SUB
     110 I $P($G(^PXD(811.2,REM,0)),U,6)=1 Q
     111 F SUB=80,80.1,81 D
     112 . S NUM=0
     113 . F  S NUM=$O(^PXD(811.3,REM,SUB,NUM)) Q:NUM<1  D
     114 .. S NODE=+$G(^PXD(811.3,REM,SUB,NUM,0))
     115 .. I 'NODE Q
     116 .. I SUB=80 D  Q
     117 ... S ^TMP("ORWG TEMP",$J,"45DX;"_NODE)=""
     118 ... S ^TMP("ORWG TEMP",$J,"9000010.07;"_NODE)=""
     119 ... S ^TMP("ORWG TEMP",$J,"9000011;"_NODE)=""
     120 .. I SUB=80.1 D  Q
     121 ... S ^TMP("ORWG TEMP",$J,"45OP;"_NODE)=""
     122 .. I SUB=81 D  Q
     123 ... S ^TMP("ORWG TEMP",$J,"9000010.18;"_NODE)=""
     124 Q
     125 ;
     126MED1(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     127 N DATE,ITEM,OK,MEDARRAY,RESULT K MEDARRAY
     128 D MEDICINE^ORWGAPIA(.MEDARRAY,DFN)
     129 S ITEM=0
     130 F  S ITEM=$O(MEDARRAY(ITEM)) Q:ITEM<1  D
     131 . S OK=0
     132 . I FMT=6 D
     133 .. S DATE=OLDEST
     134 .. F  S DATE=$O(MEDARRAY(ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     135 ... S CNT=CNT+1
     136 ... S OK=1
     137 ... S RESULT=690_U_ITEM
     138 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     139 . I FMT'=6 D
     140 .. S DATE=$O(MEDARRAY(ITEM,""),-1)
     141 .. I 'DATE Q
     142 .. S NAME=MEDARRAY(ITEM,DATE)
     143 .. I '$L(NAME) Q
     144 .. S CNT=CNT+1
     145 .. S OK=1
     146 .. I FMT=3 S RESULT=690_U_ITEM_"^^"_NAME_"^^"_DATE
     147 .. I FMT=0 S RESULT=690_U_ITEM_U_NAME
     148 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     149 Q
     150 ;
     151MED3(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     152 N DATE,DATE2,DATESTOP,DATESTRT,DTPLUS1,NODE,RESULT,STATUS,VALUE K VALUE
     153 D MEDICINE^ORWGAPIA(.MEDARRAY,DFN)
     154 S ITEM=+$G(ITEM)
     155 S CNT=$G(CNT)
     156 S DATE=""
     157 F  S DATE=$O(MEDARRAY(ITEM,DATE)) Q:DATE=""  D
     158 . I DATE>START Q
     159 . S RESULT=690_U_ITEM_U_DATE_"^^"
     160 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     161 Q
     162 ;
     163NVA1(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     164 N DATA,DATE,DATE1,DATESTRT,DRUG,ITEM,OK,REF,RESULT K DATA
     165 S ITEM=""
     166 F  S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM=""  D
     167 . S OK=0
     168 . I FMT=6 D
     169 .. S DATE=0
     170 .. F  S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     171 ... S DATE1=""
     172 ... F  S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1)) Q:DATE1=""  D  Q:OK
     173 .... I DATE1'["U",DATE1<OLDEST Q
     174 .... S CNT=CNT+1
     175 .... S OK=1
     176 .... S RESULT="55NVA"_U_ITEM
     177 . I FMT'=6 D
     178 .. S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1)
     179 .. I 'DATE Q
     180 .. S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1)
     181 .. I '$L(DATE1) Q
     182 .. S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1)
     183 .. I '$L(REF) Q
     184 .. D RXNVA^ORWGAPIA(REF,.DATA)
     185 .. S DRUG=+$G(DATA("DISPENSE DRUG"))
     186 .. S DATESTRT=+$G(DATA("START DATE"))
     187 .. I 'DATESTRT Q
     188 .. S CNT=CNT+1
     189 .. S OK=1
     190 .. I FMT=3 S RESULT="55NVA"_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)_"^^"_DATESTRT
     191 .. I FMT=0 S RESULT="55NVA"_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)
     192 .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG)
     193 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     194 Q
     195 ;
     196NVA3(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     197 N DATE1,DATE2,DATESTOP,DATESTRT,DTPLUS1,NODE,RESULT,STATUS,VALUE K VALUE
     198 S CNT=$G(CNT),DTPLUS1=$$FMADD^ORWGAPIX(DT,1)
     199 S DATE1=""
     200 F  S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1)) Q:DATE1=""  D
     201 . I DATE1>START Q
     202 . S DATE2=""
     203 . F  S DATE2=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1,DATE2)) Q:DATE2=""  D
     204 .. S NODE=""
     205 .. F  S NODE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1,DATE2,NODE)) Q:NODE=""  D
     206 ... D RXNVA^ORWGAPIA(NODE,.VALUE)
     207 ... S STATUS=$G(VALUE("STATUS"))
     208 ... S DATESTRT=+$G(VALUE("START DATE"))
     209 ... I 'DATESTRT Q
     210 ... S DATESTOP=+$G(VALUE("DISCONTINUED DATE"))
     211 ... I 'DATESTOP S DATESTOP=DTPLUS1
     212 ... S STATUS=STATUS_"  "_$$NVASIG^ORWGAPIA(NODE)
     213 ... S RESULT="55NVA"_U_ITEM_U_DATESTRT_U_DATESTOP_U_STATUS
     214 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     215 Q
     216 ;
     217PLX2(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR
     218 N DATE,DTPLUS1,ICD9,OK,PRIORITY,RESULT,STATUS
     219 K ^TMP("ORWGRPC TEMP",$J)
     220 S DTPLUS1=$$FMADD^ORWGAPIX(DT,1)
     221 S STATUS=""
     222 F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
     223 . S PRIORITY=""
     224 . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
     225 .. S ITEM=""
     226 .. F  S ITEM=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM=""  D
     227 ... S DATE=""
     228 ... F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
     229 .... S NODE=""
     230 .... F  S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE=""  D
     231 ..... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE)
     232 ..... I 'DTRESOLV S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTPLUS1 Q
     233 ..... S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTRESOLV
     234 S PROB=""
     235 F  S PROB=$O(^TMP("ORWGRPC TEMP",$J,PROB)) Q:PROB=""  D
     236 . S VALUE=$$EVALUE^ORWGAPIU(PROB,9000011,.01)
     237 . I FMT=0 D
     238 .. S CNT=CNT+1
     239 .. S RESULT=9999911_U_PROB_U_VALUE
     240 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     241 . I FMT=6 D
     242 .. S OK=0
     243 .. S DATE=0
     244 .. F  S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     245 ... S DTRESOLV=^TMP("ORWGRPC TEMP",$J,PROB,DATE)
     246 ... I DTRESOLV<OLDEST Q
     247 ... S CNT=CNT+1
     248 ... S OK=1
     249 ... S RESULT=9999911_U_PROB
     250 .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     251 . I FMT=3 D
     252 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,""),-1)
     253 .. I 'DATE Q
     254 .. S CNT=CNT+1
     255 .. S RESULT=9999911_U_PROB_"^^"_VALUE_"^^"_DATE
     256 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     257 K ^TMP("ORWGRPC TEMP",$J)
     258 Q
     259 ;
     260PROBX4(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR
     261 N DATE,DTONSET,DTPLUS1,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE
     262 K ^TMP("ORWGRPC TEMP",$J)
     263 S CNT=$G(CNT),DTPLUS1=$$FMADD^ORWGAPIX(DT,1)
     264 S STATUS=""
     265 F  S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS=""  D
     266 . S PRIORITY=""
     267 . F  S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
     268 .. S DATE=""
     269 .. F  S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
     270 ... I DATE>START Q
     271 ... S NODE=""
     272 ... F  S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE=""  D
     273 .... S ^TMP("ORWGRPC TEMP",$J,NODE)=""
     274 S NODE=""
     275 F  S NODE=$O(^TMP("ORWGRPC TEMP",$J,NODE)) Q:NODE=""  D
     276 . D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE)
     277 . I 'DTONSET Q
     278 . I 'DTRESOLV S DTRESOLV=DTPLUS1
     279 . S RESULT=9999911_U_PROBDX_U_DTONSET_U_DTRESOLV_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12)
     280 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     281 K ^TMP("ORWGRPC TEMP",$J)
     282 Q
     283 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIP.m

    r613 r623  
    1 ORWGAPIP        ; SLC/STAFF - Graph Parameters ;11/20/06  08:59
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 ALLVIEWS(DATA,VTYPE,USER)       ; from ORWGAPI
    5         N CNT,ENT,NUM,NUM1,PARAM,PROF,RESULT,TEST,TG,TGNUM,TGNAME,TMP,VIEW,VNUM K PROF,VIEW
    6         D RETURN^ORWGAPIW(.TMP,.DATA)
    7         S CNT=0
    8         I VTYPE=-2 D
    9         . S ENT="SYS"
    10         . S USER=0
    11         I VTYPE=-1 D
    12         . S ENT="USR"
    13         . I USER S ENT="USR.`"_USER
    14         I VTYPE=-3 D  Q
    15         . ;LAB GROUPS
    16         . I 'USER S USER=DUZ
    17         . D TG^ORWLRR(.PROF,USER)
    18         . S NUM=0
    19         . F  S NUM=$O(PROF(NUM)) Q:NUM<1  D
    20         .. S TG=PROF(NUM)
    21         .. S TGNUM=+TG
    22         .. S TGNAME=$P(TG,U,2)
    23         .. ;I TGNAME[") " S TGNAME=$P(TGNAME,") ",2,99)
    24         .. S VNUM=CNT+1
    25         .. S RESULT="-3^V^"_VNUM_U_TGNAME_"^^^"_USER
    26         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    27         .. K VIEW
    28         .. D ATG^ORWLRR(.VIEW,TGNUM,USER)
    29         .. S NUM1=0
    30         .. F  S NUM1=$O(VIEW(NUM1)) Q:NUM1<1  D
    31         ... S TEST=VIEW(NUM1)
    32         ... S RESULT="-3^C^"_VNUM_U_$P(TEST,U,2)_"^63^"_+TEST_U
    33         ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    34         D XGETLST^ORWGAPIX(.PROF,ENT,"ORWG GRAPH VIEW")
    35         S NUM=0
    36         F  S NUM=$O(PROF(NUM)) Q:NUM<1  D
    37         . S PARAM=$P(PROF(NUM),U)
    38         . S VNUM=CNT+1
    39         . S RESULT=VTYPE_"^V^"_VNUM_U_PARAM_"^^^"_USER
    40         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    41         . K VIEW
    42         . D XGETWP^ORWGAPIX(.VIEW,ENT,"ORWG GRAPH VIEW",PARAM)
    43         . D DEFVIEWS(.DATA,.VIEW,VTYPE,VNUM,TMP,.CNT)
    44         Q
    45         ;
    46 DATES(DAT,REPORTID)     ; from ORWGAPI
    47         N BEGIN,END,INFO,NEXT,PARAM1,PARAM2,RPT,START,STOP
    48         S RPT=+$O(^ORD(101.24,"AC",+$G(REPORTID),0))
    49         I 'RPT Q  ; RPT=1150 is exported graph report
    50         S PARAM1=$P($G(^ORD(101.24,RPT,2)),U)
    51         S PARAM2=$P($G(^ORD(101.24,RPT,2)),U,2)
    52         S INFO=$$XGET^ORWGAPIX("ALL","ORWRP TIME/OCC LIMITS INDV",RPT,"I")
    53         S BEGIN=$P(INFO,";"),START=$$DATE^ORWGAPIX(BEGIN)
    54         S END=$P(INFO,";",2),STOP=$$DATE^ORWGAPIX(END)
    55         I START<1 Q
    56         I STOP<1 Q
    57         S NEXT=1+$O(DAT(""),-1)
    58         S DAT(NEXT)=U_BEGIN_" to "_END_"^^^"_INFO_U_START_U_STOP_U_PARAM1_U_PARAM2
    59         Q
    60         ;
    61 DEFVIEWS(DATA,VIEW,VTYPE,VNUM,TMP,CNT)  ;
    62         N FIRST,NUM,PIECE,RESULT,RESULT1,SECOND,VALUE
    63         S NUM=""
    64         F  S NUM=$O(VIEW(NUM)) Q:NUM=""  D
    65         . S RESULT=$G(VIEW(NUM,0))
    66         . S PIECE=0
    67         . F  S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE)  Q:'$L($P(RESULT,"|",PIECE+1,999))
    68         .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2)
    69         .. I FIRST=0 D
    70         ... I $E(SECOND,1,5)="63AP;" S RESULT1=VTYPE_"^C^"_VNUM_U_"Anatomic Path: "_$$ITEMPRFX^ORWGAPIU($E(SECOND,3,6))_" <any>"_U_SECOND_"^0^" Q
    71         ... I $E(SECOND,1,5)="63MI;" S RESULT1=VTYPE_"^C^"_VNUM_U_"Microbiology: "_$$ITEMPRFX^ORWGAPIU($E(SECOND,3,6))_" <any>"_U_SECOND_"^0^" Q
    72         ... S RESULT1=VTYPE_"^C^"_VNUM_U_$$FILENAME^ORWGAPIT(SECOND)_" <any>"_U_SECOND_"^0^"
    73         .. I FIRST'=0 S RESULT1=VTYPE_"^C^"_VNUM_U_$$EVALUE^ORWGAPIU(SECOND,FIRST)_U_FIRST_U_SECOND_U
    74         .. D SETUP^ORWGAPIW(.DATA,RESULT1,TMP,.CNT)
    75         Q
    76         ;
    77 DELVIEWS(DATA,NAME,PUBLIC)      ; from ORWGAPI
    78         N ERR,TMP
    79         D RETURN^ORWGAPIW(.TMP,.DATA)
    80         S ERR=0
    81         I '$L(NAME) S ERR=1
    82         I 'ERR D
    83         . S NAME=$$UP^ORWGAPIX(NAME)
    84         . I PUBLIC D XDEL^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.ERR)
    85         . I 'PUBLIC  D XDEL^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.ERR)
    86         I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
    87         I 'TMP S DATA=ERR,DATA(1)=ERR
    88         Q
    89         ;
    90 GETPREF(DATA)   ; from ORWGAPI
    91         N CNT,NUM,PROF,RESULT,TMP,VAL K PROF
    92         I '$O(^PXRMINDX(63,"PI","")) Q  ; graphing is not used if no indexes
    93         S VAL=$$XGET^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,"I")
    94         I '$L(VAL) Q  ; graphing not used if no pkg param on settings
    95         D RETURN^ORWGAPIW(.TMP,.DATA)
    96         S PROF(2)=1
    97         I '$L($G(^XTMP("ORGRAPH",0))) S PROF(2)=-1
    98         S VAL=$$XGET^ORWGAPIX("DIV^SYS^PKG","ORWG GRAPH SETTING",1,"I")
    99         S PROF(1)=VAL
    100         S VAL=$$XGET^ORWGAPIX("ALL","ORWG GRAPH SETTING",1,"I")
    101         S PROF(0)=VAL
    102         S CNT=0
    103         S NUM=""
    104         F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
    105         . S RESULT=$G(PROF(NUM))
    106         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    107         Q
    108         ;
    109 GETSIZE(DATA)   ; from ORWGAPI
    110         N CNT,NUM,PROF,RESULT,TMP K PROF
    111         D RETURN^ORWGAPIW(.TMP,.DATA)
    112         D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH SIZING")
    113         S CNT=0
    114         S NUM=""
    115         F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
    116         . S RESULT=$G(PROF(NUM))
    117         . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    118         Q
    119         ;
    120         ;GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; from ORWGAPI
    121         ;N CNT,NUM,PROF,RESULT,TMP,USERPRM K PROF
    122         ;D RETURN^ORWGAPIW(.TMP,.DATA)
    123         ;I PUBLIC D
    124         ;. I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views
    125         ;. I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition
    126         ;I 'PUBLIC D
    127         ;. S USERPRM="USR"
    128         ;. I USER S USERPRM="USR.`"_USER
    129         ;. I ALL=1 D XGETLST^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW") ; get list of personal views
    130         ;. I ALL'=1 D XGETWP^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW",ALL) ; get a personal view definition
    131         ;S CNT=0
    132         ;I 'EXT D  Q
    133         ;. S NUM=""
    134         ;. F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
    135         ;.. I ALL=1 S RESULT=$P($G(PROF(NUM)),U)
    136         ;.. I ALL'=1 S RESULT=$G(PROF(NUM,0))
    137         ;.. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    138         ;D DEFVIEWS(.DATA,.PROF,"",TMP,.CNT)
    139         ;Q
    140         ;
    141 GETVIEWS(DATA,ALL,PUBLIC,EXT,USER)      ; from ORWGAPI
    142         N CNT,FIRST,NUM,PIECE,PROF,RESULT,RESULT1,SECOND,TMP,VALUE K PROF
    143         D RETURN^ORWGAPIW(.TMP,.DATA)
    144         I PUBLIC D
    145         . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views
    146         . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition
    147         I 'PUBLIC D
    148         . S USERPRM="USR"
    149         . I USER S USERPRM="USR.`"_USER
    150         . I ALL=1 D XGETLST^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW") ; get list of personal views
    151         . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW",ALL) ; get a personal view definition
    152         S CNT=0
    153         I 'EXT D  Q
    154         . S NUM=""
    155         . F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
    156         .. I ALL=1 S RESULT=$P($G(PROF(NUM)),U)
    157         .. I ALL'=1 S RESULT=$G(PROF(NUM,0))
    158         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    159         S NUM=""
    160         F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
    161         . S RESULT=$G(PROF(NUM,0))
    162         . S PIECE=0
    163         . F  S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE)  Q:'$L($P(RESULT,"|",PIECE+1,999))
    164         .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2)
    165         .. I FIRST=0 S CNT=CNT+1,RESULT1="0^"_SECOND_U_$$FILENAME^ORWGAPIT(SECOND)_" <any>"
    166         .. I FIRST'=0 S CNT=CNT+1,RESULT1=FIRST_U_SECOND_U_$$EVALUE^ORWGAPIU(SECOND,FIRST)
    167         .. D SETUP^ORWGAPIW(.DATA,RESULT1,TMP,.CNT)
    168         Q
    169         ;
    170 INISET  ; from ORWGAPIU initial setup of package parameters
    171         N ERR,RPTNUM
    172         S RPTNUM=1150
    173         D SETPREF(.ERR,"63;53.79;55;55NVA;52;70;120.5|BCEFGHIKN|1|4|90|1|100||",9) ; default public settings
    174         I '$D(^ORD(101.24,RPTNUM,0)) D  ; make sure report has been added
    175         . L +^ORD(101.24,0):20 I '$T Q
    176         . S $P(^ORD(101.24,0),U,3)=RPTNUM,$P(^(0),U,4)=$P(^(0),U,4)+1
    177         . S ^ORD(101.24,RPTNUM,0)="ORWG GRAPHING^OR_GRAPHS^^2^^^1^R^^^^G^^T"
    178         . S ^ORD(101.24,RPTNUM,2)="^^Graphing (local only)^Graphing"
    179         . L -^ORD(101.24,0)
    180         . D INDEX^ORWGAPIX("^ORD(101.24,",RPTNUM)
    181         D XEN^ORWGAPIX("PKG","ORWRP REPORT LIST",12,RPTNUM)
    182         Q
    183         ;
    184 PUBLIC(USER)    ; from ORWGAPI
    185         N ERR,IDX,ORSRV,USRCLASS,VAL K USRCLASS
    186         S VAL=0
    187         I '$G(USER) Q VAL
    188         S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
    189         D XGETLST1^ORWGAPIX(.USRCLASS,"SYS","ORWG GRAPH PUBLIC EDITOR CLASS","Q",.ERR)
    190         I ERR Q VAL
    191         S IDX=0
    192         F  S IDX=$O(USRCLASS(IDX)) Q:'IDX  D  Q:VAL
    193         . I $$ISA^ORWGAPIA(USER,$P(USRCLASS(IDX),U,2),.ERR) S VAL=1
    194         Q VAL
    195         ;
    196 RPTPARAM(IEN)   ; from ORWGAPI
    197         N DATES,NODE,VAL
    198         S IEN=+$G(IEN)
    199         S VAL=""
    200         S NODE=$$UP^XLFSTR($P($G(^ORD(101.24,IEN,2)),U,1,2))
    201         I $L(NODE)<2 Q VAL
    202         Q NODE
    203         ;
    204 SETPREF(DATA,VAL,PUBLIC)        ; from ORWGAPI
    205         N ERR,TMP
    206         D RETURN^ORWGAPIW(.TMP,.DATA)
    207         S ERR=0
    208         I '$L(VAL) S ERR=1
    209         I 'ERR D
    210         . S VAL=$$UP^ORWGAPIX(VAL)
    211         . I PUBLIC=9 D XEN^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,VAL,.ERR) ; only on postinit
    212         . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH SETTING",1,VAL,.ERR)
    213         . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH SETTING",1,VAL,.ERR)
    214         I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
    215         I 'TMP S DATA=ERR,DATA(1)=ERR
    216         Q
    217         ;
    218 SETSIZE(DATA,VAL)       ; from ORWGAPI
    219         N ERR,NAME,NUM,VALUE,VALUES,TMP
    220         D RETURN^ORWGAPIW(.TMP,.DATA)
    221         S ERR=0
    222         I '$L($O(VAL(0))) S ERR=1
    223         I 'ERR D
    224         . S NUM=0
    225         . F  S NUM=$O(VAL(NUM)) Q:NUM<1  D  Q:ERR
    226         .. S VALUES=VAL(NUM)
    227         .. S VALUES=$$UP^ORWGAPIX(VALUES)
    228         .. S NAME=$P(VALUES,U)
    229         .. S VALUE=$P(VALUES,U,2)
    230         .. D XEN^ORWGAPIX("USR","ORWG GRAPH SIZING",NAME,VALUE,.ERR)
    231         I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
    232         I 'TMP S DATA=ERR,DATA(1)=ERR
    233         Q
    234         ;
    235 SETVIEWS(DATA,NAME,PUBLIC,VAL)  ; from ORWGAPI
    236         N ERR,TMP
    237         D RETURN^ORWGAPIW(.TMP,.DATA)
    238         S ERR=0
    239         I '$L(NAME) S ERR=1
    240         I '$L($O(VAL(""))) S ERR=1
    241         I 'ERR D
    242         . S NAME=$$UP^ORWGAPIX(NAME)
    243         . S VAL=NAME
    244         . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.VAL,.ERR)
    245         . I 'PUBLIC  D XEN^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.VAL,.ERR)
    246         I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
    247         I 'TMP S DATA=ERR,DATA(1)=ERR
    248         Q
    249         ;
     1ORWGAPIP ; SLC/STAFF - Graph Parameters ;11/20/06  08:59
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
     3 ;
     4DATES(DAT,REPORTID) ; from ORWGAPI
     5 N BEGIN,END,INFO,NEXT,PARAM1,PARAM2,RPT,START,STOP
     6 S RPT=+$O(^ORD(101.24,"AC",+$G(REPORTID),0))
     7 I 'RPT Q  ; RPT=1150 is exported graph report
     8 S PARAM1=$P($G(^ORD(101.24,RPT,2)),U)
     9 S PARAM2=$P($G(^ORD(101.24,RPT,2)),U,2)
     10 S INFO=$$XGET^ORWGAPIX("ALL","ORWRP TIME/OCC LIMITS INDV",RPT,"I")
     11 S BEGIN=$P(INFO,";"),START=$$DATE^ORWGAPIX(BEGIN)
     12 S END=$P(INFO,";",2),STOP=$$DATE^ORWGAPIX(END)
     13 I START<1 Q
     14 I STOP<1 Q
     15 S NEXT=1+$O(DAT(""),-1)
     16 S DAT(NEXT)=U_BEGIN_" to "_END_"^^^"_INFO_U_START_U_STOP_U_PARAM1_U_PARAM2
     17 Q
     18 ;
     19DELVIEWS(DATA,NAME,PUBLIC) ; from ORWGAPI
     20 N ERR,TMP
     21 D RETURN^ORWGAPIU(.TMP,.DATA)
     22 S ERR=0
     23 I '$L(NAME) S ERR=1
     24 I 'ERR D
     25 . S NAME=$$UP^ORWGAPIX(NAME)
     26 . I PUBLIC D XDEL^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.ERR)
     27 . I 'PUBLIC  D XDEL^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.ERR)
     28 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
     29 I 'TMP S DATA=ERR,DATA(1)=ERR
     30 Q
     31 ;
     32GETPREF(DATA) ; from ORWGAPI
     33 N CNT,NUM,PROF,RESULT,TMP,VAL K PROF
     34 I '$O(^PXRMINDX(63,"PI","")) Q  ; graphing is not used if no indexes
     35 S VAL=$$XGET^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,"I")
     36 I '$L(VAL) Q  ; graphing not used if no pkg param on settings
     37 D RETURN^ORWGAPIU(.TMP,.DATA)
     38 S VAL=$$XGET^ORWGAPIX("DIV^SYS^PKG","ORWG GRAPH SETTING",1,"I")
     39 S PROF(1)=VAL
     40 S VAL=$$XGET^ORWGAPIX("ALL","ORWG GRAPH SETTING",1,"I")
     41 S PROF(0)=VAL
     42 S CNT=0
     43 S NUM=""
     44 F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
     45 . S RESULT=$G(PROF(NUM))
     46 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     47 Q
     48 ;
     49GETSIZE(DATA) ; from ORWGAPI
     50 N CNT,NUM,PROF,RESULT,TMP K PROF
     51 D RETURN^ORWGAPIU(.TMP,.DATA)
     52 D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH SIZING")
     53 S CNT=0
     54 S NUM=""
     55 F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
     56 . S RESULT=$G(PROF(NUM))
     57 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     58 Q
     59 ;
     60GETVIEWS(DATA,ALL,PUBLIC,EXT) ; from ORWGAPI
     61 N CNT,FIRST,NUM,PIECE,PROF,RESULT,RESULT1,SECOND,TMP,VALUE K PROF
     62 D RETURN^ORWGAPIU(.TMP,.DATA)
     63 I PUBLIC D
     64 . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views
     65 . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition
     66 I 'PUBLIC D
     67 . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH VIEW") ; get list of personal views
     68 . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"USR","ORWG GRAPH VIEW",ALL) ; get a personal view definition
     69 S CNT=0
     70 I 'EXT D  Q
     71 . S NUM=""
     72 . F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
     73 .. I ALL=1 S RESULT=$P($G(PROF(NUM)),U)
     74 .. I ALL'=1 S RESULT=$G(PROF(NUM,0))
     75 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     76 S NUM=""
     77 F  S NUM=$O(PROF(NUM)) Q:NUM=""  D
     78 . S RESULT=$G(PROF(NUM,0))
     79 . S PIECE=0
     80 . F  S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE)  Q:'$L($P(RESULT,"|",PIECE+1,999))
     81 .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2)
     82 .. I FIRST=0 S CNT=CNT+1,RESULT1="0^"_SECOND_U_$$FILENAME^ORWGAPIT(SECOND)_" <any>"
     83 .. I FIRST'=0 S CNT=CNT+1,RESULT1=FIRST_U_SECOND_U_$$EVALUE^ORWGAPIU(SECOND,FIRST)
     84 .. D SETUP^ORWGAPIU(.DATA,RESULT1,TMP,.CNT)
     85 Q
     86 ;
     87INISET ; from ORWGAPIU initial setup of package parameters
     88 N ERR,RPTNUM
     89 S RPTNUM=1150
     90 D SETPREF(.ERR,"63;53.79;55;55NVA;52;70;120.5|BCEFGHIK|1|4|90||100||",9) ; default public settings
     91 I '$D(^ORD(101.24,RPTNUM,0)) D  ; make sure report has been added
     92 . L +^ORD(101.24,0):20 I '$T Q
     93 . S $P(^ORD(101.24,0),U,3)=RPTNUM,$P(^(0),U,4)=$P(^(0),U,4)+1
     94 . S ^ORD(101.24,RPTNUM,0)="ORWG GRAPHING^OR_GRAPHS^^2^^^1^R^^^^G^^T"
     95 . S ^ORD(101.24,RPTNUM,2)="^^Graphing (local only)^Graphing"
     96 . L -^ORD(101.24,0)
     97 . D INDEX^ORWGAPIX("^ORD(101.24,",RPTNUM)
     98 D XEN^ORWGAPIX("PKG","ORWRP REPORT LIST",12,RPTNUM)
     99 D XVIEWS ; *****
     100 Q
     101 ;
     102PUBLIC(USER) ; from ORWGAPI
     103 N ERR,IDX,ORSRV,USRCLASS,VAL K USRCLASS
     104 S VAL=0
     105 I '$G(USER) Q VAL
     106 S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
     107 D XGETLST1^ORWGAPIX(.USRCLASS,"SYS","ORWG GRAPH PUBLIC EDITOR CLASS","Q",.ERR)
     108 I ERR Q VAL
     109 S IDX=0
     110 F  S IDX=$O(USRCLASS(IDX)) Q:'IDX  D  Q:VAL
     111 . I $$ISA^ORWGAPIA(USER,$P(USRCLASS(IDX),U,2),.ERR) S VAL=1
     112 Q VAL
     113 ;
     114RPTPARAM(IEN) ; from ORWGAPI
     115 N NODE,VAL
     116 S VAL=""
     117 S NODE=$$UP^XLFSTR($P($G(^ORD(101.24,+$G(IEN),2)),U,1,2))
     118 I $L(NODE)<2 Q VAL
     119 Q NODE
     120 ;
     121SETPREF(DATA,VAL,PUBLIC) ; from ORWGAPI
     122 N ERR,TMP
     123 D RETURN^ORWGAPIU(.TMP,.DATA)
     124 S ERR=0
     125 I '$L(VAL) S ERR=1
     126 I 'ERR D
     127 . S VAL=$$UP^ORWGAPIX(VAL)
     128 . I PUBLIC=9 D XEN^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,VAL,.ERR) ; only on postinit
     129 . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH SETTING",1,VAL,.ERR)
     130 . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH SETTING",1,VAL,.ERR)
     131 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
     132 I 'TMP S DATA=ERR,DATA(1)=ERR
     133 Q
     134 ;
     135SETSIZE(DATA,VAL) ; from ORWGAPI
     136 N ERR,NAME,NUM,VALUE,VALUES,TMP
     137 D RETURN^ORWGAPIU(.TMP,.DATA)
     138 S ERR=0
     139 I '$L($O(VAL(0))) S ERR=1
     140 I 'ERR D
     141 . S NUM=0
     142 . F  S NUM=$O(VAL(NUM)) Q:NUM<1  D  Q:ERR
     143 .. S VALUES=VAL(NUM)
     144 .. S VALUES=$$UP^ORWGAPIX(VALUES)
     145 .. S NAME=$P(VALUES,U)
     146 .. S VALUE=$P(VALUES,U,2)
     147 .. D XEN^ORWGAPIX("USR","ORWG GRAPH SIZING",NAME,VALUE,.ERR)
     148 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
     149 I 'TMP S DATA=ERR,DATA(1)=ERR
     150 Q
     151 ;
     152SETVIEWS(DATA,NAME,PUBLIC,VAL) ; from ORWGAPI
     153 N ERR,TMP
     154 D RETURN^ORWGAPIU(.TMP,.DATA)
     155 S ERR=0
     156 I '$L(NAME) S ERR=1
     157 I '$L($O(VAL(""))) S ERR=1
     158 I 'ERR D
     159 . S NAME=$$UP^ORWGAPIX(NAME)
     160 . S VAL=NAME
     161 . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.VAL,.ERR)
     162 . I 'PUBLIC  D XEN^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.VAL,.ERR)
     163 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR
     164 I 'TMP S DATA=ERR,DATA(1)=ERR
     165 Q
     166 ;
     167XVIEWS ; conversion on v26t41 *****
     168 N CNT,DATA,ERR,NAME,NUM,NUM1,SYSNAME,VIEWS,VIEWDEF,VIEWDIV
     169 K DATA,SYSNAME,VIEWS,VIEWDEF,VIEWDIV
     170 D XGETLST^ORWGAPIX(.VIEWS,"SYS","ORWG GRAPH VIEW")
     171 S NUM=0
     172 F  S NUM=$O(VIEWS(NUM)) Q:NUM<1  D
     173 . S NAME=$P(VIEWS(NUM),U)
     174 . I NAME="" Q
     175 . S SYSNAME(NAME)=""
     176 K VIEWS
     177 D XGETLST^ORWGAPIX(.VIEWS,"DIV","ORWG GRAPH VIEW")
     178 S NUM=0
     179 F  S NUM=$O(VIEWS(NUM)) Q:NUM<1  D
     180 . S NAME=$P(VIEWS(NUM),U)
     181 . I NAME="" Q
     182 . I '$D(SYSNAME(NAME)) D
     183 .. K VIEWDEF,VIEWDIV
     184 .. D XGETWP^ORWGAPIX(.VIEWDIV,"DIV","ORWG GRAPH VIEW",NAME)
     185 .. S CNT=0
     186 .. S NUM1=""
     187 .. F  S NUM1=$O(VIEWDIV(NUM1)) Q:NUM1=""  D
     188 ... S CNT=CNT+1
     189 ... S VIEWDEF(CNT)=$G(VIEWDIV(NUM1,0))
     190 .. D SETVIEWS^ORWGAPIP(.DATA,NAME,1,.VIEWDEF)
     191 . D XDEL^ORWGAPIX("DIV","ORWG GRAPH VIEW",NAME,.ERR)
     192 Q
     193 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIR.m

    r613 r623  
    1 ORWGAPIR        ; SLC/STAFF - Graph API Router ;8/21/06  07:52
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 DATA(DATA,ITEM,FILE,START,DFN,CNT,TMP,BACKTO)   ; from ORWGAPI
    5         S DFN=+$G(DFN) I 'DFN Q
    6         S FILE=$G(FILE) I '$L(FILE) Q
    7         S ITEM=$G(ITEM) I '$L(ITEM) Q
    8         S BACKTO=+$G(BACKTO)
    9         I FILE=52 D OUTRX^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    10         I FILE=53.79 D BCMA^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    11         I FILE=55 D INRX^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    12         I FILE="55NVA" D NVA^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    13         I FILE=63 D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    14         I FILE="63AP" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    15         ;I FILE="63BB" D BBDATA^ORWGAPIB(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    16         I FILE="63MI" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    17         I FILE=70 D RAD^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    18         I FILE=100 D ORDER^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    19         I FILE=120.5 D VITAL^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    20         I FILE=120.8 D ADVERSE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    21         I FILE=601.2 D MH^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    22         I FILE=9000010.07 D POV^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    23         I FILE=9000010.11 D IMM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    24         I FILE=9000010.12 D SKIN^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    25         I FILE=9000010.13 D EXAM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    26         I FILE=9000010.16 D EDU^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    27         I FILE=9000010.18 D PROC^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    28         I FILE=9000010.23 D HF^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    29         I FILE=9000011 D PROB^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    30         I FILE=9999911 D PROBX^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    31         I FILE="45OP" D OP^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    32         I FILE="45DX" D DX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    33         I FILE=9000010 D VISIT^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    34         I FILE=405 D ADMIT^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    35         I FILE=130 D SURG^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    36         I FILE=8925 D NOTE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    37         I FILE=690 D MED^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q
    38         Q
    39         ;
    40 ITEMS(ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPI
    41         S FMT=$G(FMT,3),OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),CNT=+$G(CNT)
    42         I (TYPE=70)!(TYPE=100)!(TYPE=120.5)!(TYPE=601.2) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    43         I (TYPE=9000010.11)!(TYPE=9000010.12)!(TYPE=9000010.13) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    44         I (TYPE=9000010.16)!(TYPE=9000010.23) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    45         I (TYPE=9000010.07)!(TYPE=9000010.18) D STD1(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    46         I (TYPE=52)!(TYPE=55) D STD2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    47         I TYPE=63 D LAB^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    48         I TYPE=9000010 D VISITS^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    49         I TYPE=9000011 D PL^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    50         I TYPE=9999911 D PLX^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    51         I TYPE=405 D ADMITS^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    52         I TYPE=50.605 D DC^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    53         I TYPE=68 D AA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    54         I TYPE=8925.1 D TITLE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    55         I TYPE=53.79 D BCMA^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    56         I TYPE=120.8 D ADVERSE^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    57         I TYPE=130 D SURGERY^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    58         I TYPE=8925 D NOTES^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    59         I TYPE=690 D MED^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    60         S TYPE=$$UP^ORWGAPIX(TYPE)
    61         I $E(TYPE,1,2)=45 D REG^ORWGAPI2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    62         I TYPE="55NVA" D NVA^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    63         I TYPE="63AP" D AP^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    64         I TYPE="63BB" D BBITEM^ORWGAPIB(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    65         I TYPE="63MI" D MI^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
    66         Q
    67         ;
    68 STD(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP)   ;
    69         N DATE,ITEM,OK,RESULT
    70         S ITEM=""
    71         F  S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM=""  D
    72         . S OK=0
    73         . I FMT=6 D
    74         .. S DATE=OLDEST
    75         .. F  S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    76         ... S CNT=CNT+1
    77         ... S OK=1
    78         ... S RESULT=FILE_U_ITEM
    79         . I FMT=3 D
    80         .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1)
    81         .. I 'DATE Q
    82         .. S CNT=CNT+1
    83         .. S OK=1
    84         .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE
    85         .. I FILE=100 S RESULT=RESULT_U_$$OGROUP^ORWGAPIW(ITEM)
    86         . I FMT=0 D
    87         .. S CNT=CNT+1
    88         .. S OK=1
    89         .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)
    90         . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    91         I FILE=120.5 D BMIITEMS^ORWGAPIX(.ITEMS,.CNT,TMP) Q
    92         Q
    93         ;
    94 STD1(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP)  ;
    95         N DATE,ITEM,OK,RESULT,TYPE
    96         K ^TMP("ORWGRPC TEMP",$J)
    97         S TYPE=""
    98         F  S TYPE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE)) Q:TYPE=""  D
    99         . S ITEM=""
    100         . F  S ITEM=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM)) Q:ITEM=""  D
    101         .. S OK=0
    102         .. I FMT=6 D
    103         ... S DATE=OLDEST
    104         ... F  S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    105         .... S CNT=CNT+1
    106         .... S OK=1
    107         .... S RESULT=FILE_U_ITEM
    108         .. I FMT=3 D
    109         ... S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,""),-1)
    110         ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=""
    111         .. I FMT=0 D
    112         ... S CNT=CNT+1
    113         ... S OK=1
    114         ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)
    115         .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    116         I FMT=3 D
    117         . S ITEM=""
    118         . F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM=""  D
    119         .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1)
    120         .. I 'DATE Q
    121         .. S CNT=CNT+1
    122         .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE
    123         .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    124         K ^TMP("ORWGRPC TEMP",$J)
    125         Q
    126         ;
    127 STD2(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP)  ;
    128         N DATE,DATE2,ITEM,OK,RESULT
    129         S ITEM=""
    130         F  S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM=""  D
    131         . S OK=0
    132         . I FMT=6 D
    133         .. S DATE=0
    134         .. F  S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
    135         ... S DATE2=""
    136         ... F  S DATE2=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2=""  D
    137         .... I DATE2<OLDEST Q
    138         .... S CNT=CNT+1
    139         .... S OK=1
    140         .... S RESULT=FILE_U_ITEM
    141         . I FMT=3 D
    142         .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1)
    143         .. I 'DATE Q
    144         .. S CNT=CNT+1
    145         .. S OK=1
    146         .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE
    147         .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIC(ITEM)
    148         . I FMT=0 D
    149         .. S CNT=CNT+1
    150         .. S OK=1
    151         .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)
    152         .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIC(ITEM)
    153         . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    154         Q
    155         ;
     1ORWGAPIR ; SLC/STAFF - Graph API Router ;8/21/06  07:52
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
     3 ;
     4DATA(DATA,ITEM,FILE,START,DFN,CNT,TMP) ; from ORWGAPI
     5 S DFN=+$G(DFN) I 'DFN Q
     6 S FILE=$G(FILE) I '$L(FILE) Q
     7 S ITEM=$G(ITEM) I '$L(ITEM) Q
     8 I FILE=52 D OUTRX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     9 I FILE=53.79 D BCMA^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     10 I FILE=55 D INRX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     11 I FILE="55NVAE" D NVAE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     12 I FILE="55NVA" D NVA^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     13 I FILE=63 D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     14 I FILE="63AP" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     15 I FILE="63BB" D BBDATA^ORWGAPIB(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     16 I FILE="63MI" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     17 I FILE=70 D RAD^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     18 I FILE=100 D ORDER^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     19 I FILE=120.5 D VITAL^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     20 I FILE=120.8 D ADVERSE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     21 I FILE=601.2 D MH^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     22 I FILE=9000010.07 D POV^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     23 I FILE=9000010.11 D IMM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     24 I FILE=9000010.12 D SKIN^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     25 I FILE=9000010.13 D EXAM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     26 I FILE=9000010.16 D EDU^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     27 I FILE=9000010.18 D PROC^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     28 I FILE=9000010.23 D HF^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     29 I FILE=9000011 D PROB^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     30 I FILE=9999911 D PROBX^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     31 I FILE="45OP" D OP^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     32 I FILE="45DX" D DX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     33 I FILE=9000010 D VISIT^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     34 I FILE=405 D ADMIT^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     35 I FILE=130 D SURG^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     36 I FILE=8925 D NOTE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     37 I FILE=9000010.15 D TREAT^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     38 I FILE=690 D MED^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q
     39 Q
     40 ;
     41ITEMS(ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPI
     42 S FMT=$G(FMT,3),OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),CNT=+$G(CNT)
     43 I (TYPE=70)!(TYPE=100)!(TYPE=120.5)!(TYPE=601.2) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     44 I (TYPE=9000010.11)!(TYPE=9000010.12)!(TYPE=9000010.13) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     45 I (TYPE=9000010.15)!(TYPE=9000010.16)!(TYPE=9000010.23) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     46 I (TYPE=9000010.07)!(TYPE=9000010.18) D STD1(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     47 I (TYPE=52)!(TYPE=55) D STD2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     48 I TYPE=63 D LAB^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     49 I TYPE=9000010 D VISITS^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     50 I TYPE=9000010.15 D TREAT^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     51 I TYPE=9000011 D PL^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     52 I TYPE=9999911 D PLX^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     53 I TYPE=405 D ADMITS^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     54 I TYPE=50.605 D DC^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     55 I TYPE=68 D AA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     56 I TYPE=8925.1 D TITLE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     57 I TYPE=53.79 D BCMA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     58 I TYPE=120.8 D ADVERSE^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     59 I TYPE=130 D SURGERY^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     60 I TYPE=8925 D NOTES^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     61 I TYPE=690 D MED^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     62 S TYPE=$$UP^ORWGAPIX(TYPE)
     63 I $E(TYPE,1,2)=45 D REG^ORWGAPI2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     64 I TYPE="55NVAE" D NVAE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     65 I TYPE="55NVA" D NVA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     66 I TYPE="63AP" D AP^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     67 I TYPE="63BB" D BBITEM^ORWGAPIB(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     68 I TYPE="63MI" D MI^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q
     69 Q
     70 ;
     71STD(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ;
     72 N DATE,ITEM,OK,RESULT
     73 S ITEM=""
     74 F  S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM=""  D
     75 . S OK=0
     76 . I FMT=6 D
     77 .. S DATE=OLDEST
     78 .. F  S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     79 ... S CNT=CNT+1
     80 ... S OK=1
     81 ... S RESULT=FILE_U_ITEM
     82 . I FMT=3 D
     83 .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1)
     84 .. I 'DATE Q
     85 .. S CNT=CNT+1
     86 .. S OK=1
     87 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE
     88 .. I FILE=100 S RESULT=RESULT_U_$$OGROUP^ORWGAPIU(ITEM)
     89 . I FMT=0 D
     90 .. S CNT=CNT+1
     91 .. S OK=1
     92 .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)
     93 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     94 I FILE=120.5 D BMIITEMS^ORWGAPIX(.ITEMS,.CNT,TMP) Q
     95 Q
     96 ;
     97STD1(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ;
     98 N DATE,ITEM,OK,RESULT,TYPE
     99 K ^TMP("ORWGRPC TEMP",$J)
     100 S TYPE=""
     101 F  S TYPE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE)) Q:TYPE=""  D
     102 . S ITEM=""
     103 . F  S ITEM=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM)) Q:ITEM=""  D
     104 .. S OK=0
     105 .. I FMT=6 D
     106 ... S DATE=OLDEST
     107 ... F  S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     108 .... S CNT=CNT+1
     109 .... S OK=1
     110 .... S RESULT=FILE_U_ITEM
     111 .. I FMT=3 D
     112 ... S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,""),-1)
     113 ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=""
     114 .. I FMT=0 D
     115 ... S CNT=CNT+1
     116 ... S OK=1
     117 ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)
     118 .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     119 I FMT=3 D
     120 . S ITEM=""
     121 . F  S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM=""  D
     122 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1)
     123 .. I 'DATE Q
     124 .. S CNT=CNT+1
     125 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE
     126 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     127 K ^TMP("ORWGRPC TEMP",$J)
     128 Q
     129 ;
     130STD2(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ;
     131 N DATE,DATE2,ITEM,OK,RESULT
     132 S ITEM=""
     133 F  S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM=""  D
     134 . S OK=0
     135 . I FMT=6 D
     136 .. S DATE=0
     137 .. F  S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE=""  Q:DATE>NEWEST  D  Q:OK
     138 ... S DATE2=""
     139 ... F  S DATE2=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2=""  D
     140 .... I DATE2<OLDEST Q
     141 .... S CNT=CNT+1
     142 .... S OK=1
     143 .... S RESULT=FILE_U_ITEM
     144 . I FMT=3 D
     145 .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1)
     146 .. I 'DATE Q
     147 .. S CNT=CNT+1
     148 .. S OK=1
     149 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE
     150 .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(ITEM)
     151 . I FMT=0 D
     152 .. S CNT=CNT+1
     153 .. S OK=1
     154 .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)
     155 .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(ITEM)
     156 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     157 Q
     158 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIT.m

    r613 r623  
    1 ORWGAPIT        ; SLC/STAFF - Graph Item Types ;11/20/06  08:58
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 COMPTYPE(FILE)  ; $$(file) -> hs component abbrv   - from ORWGAPID
    5         N COMP,COMPNAME,COMPS,NUM,OK K COMPS
    6         S COMPNAME=$$COMPNAME(FILE)_"]"
    7         D COMP^ORWRP2(.COMPS)
    8         S COMP=""
    9         S OK=0
    10         S NUM=0
    11         D
    12         . F  S NUM=$O(COMPS(NUM)) Q:NUM<1  D  I OK Q
    13         .. S COMP=COMPS(NUM)
    14         .. I COMP[COMPNAME,COMPNAME=$P($P(COMP,U,2),"[",2) S OK=1
    15         Q COMP
    16         ;
    17 COMPNAME(FILE)  ; $$(file) -> hs component abbrv
    18         I FILE=63 Q "CH"
    19         I FILE=120.5 Q "VSD"
    20         I FILE=120.8 Q "ADR"
    21         I FILE=52 Q "RXOP"
    22         I FILE=55 Q "RXUD"
    23         I FILE=70 Q "II"
    24         I FILE=9000010.11 Q "IM"
    25         I FILE=9000010.12 Q "ST"
    26         I FILE=9000010.13 Q "EXAM"
    27         I FILE=9000010.18 Q "CPT"
    28         I FILE=9000011 Q "PLL"
    29         I FILE=9999911 Q "PLL"
    30         I FILE=9000010.23 Q "HF"
    31         I FILE=9000010.07 Q "OD"
    32         I FILE=9000010.16 Q "ED"
    33         I FILE=601.2 Q "MHPE"
    34         I FILE=100 Q "ORC"
    35         I FILE="45OP" Q "PRC"
    36         I FILE="45DX" Q "DD"
    37         I FILE="63AP" Q "SP"
    38         I FILE="63BB" Q "BT"
    39         I FILE="63MI" Q "MIC"
    40         I FILE=9000010 Q "CVP"
    41         I FILE=405 Q "ADC"
    42         I FILE="55NVA" Q "RXNV"
    43         I FILE=53.79 Q "BCMA"
    44         I FILE=130 Q "SR"
    45         I FILE=8925 Q "CNB"
    46         I FILE=690 Q "MEDF"
    47         Q ""
    48         ;
    49 FILENAME(FILE)  ; $$(file) -> filename   - from ORWGAPIP
    50         I FILE=63 Q "LAB TESTS"
    51         I FILE=120.5 Q "VITALS"
    52         I FILE=120.8 Q "ALLERGIES"
    53         I FILE=52 Q "MEDICATION,OUTPATIENT"
    54         I FILE=55 Q "MEDICATION,INPATIENT"
    55         I FILE=70 Q "RADIOLOGY EXAMS"
    56         I FILE=9000010.11 Q "IMMUNIZATIONS"
    57         I FILE=9000010.12 Q "SKIN TESTS"
    58         I FILE=9000010.13 Q "EXAMS"
    59         I FILE=9000010.18 Q "PROCEDURES"
    60         I FILE=9000011 Q "PROBLEMS"
    61         I FILE=9999911 Q "PROBLEMS-DURATION" ;**************
    62         I FILE=9000010.23 Q "HEALTH FACTORS"
    63         I FILE=9000010.07 Q "PURPOSE OF VISIT"
    64         I FILE=9000010.16 Q "PATIENT EDUCATION"
    65         I FILE=601.2 Q "MENTAL HEALTH"
    66         I FILE=100 Q "ORDERS"
    67         I FILE="45OP" Q "REGISTRATION OP/PROC"
    68         I FILE="45DX" Q "REGISTRATION DX"
    69         I FILE="63AP" Q "ANATOMIC PATHOLOGY"
    70         I FILE="63BB" Q "BLOOD PRODUCTS"
    71         I FILE="63MI" Q "MICROBIOLOGY"
    72         I FILE=9000010 Q "VISITS"
    73         I FILE=405 Q "ADMISSIONS"
    74         I FILE="55NVA" Q "MEDICATION,NON-VA"
    75         I FILE=53.79 Q "MEDICATION,BCMA"
    76         I FILE=50.605 Q "DRUG CLASS"
    77         I FILE=68 Q "LAB ACC AREA"
    78         I FILE=8925.1 Q "NOTE TITLE"
    79         I FILE=100.98 Q "ORDER DISPLAY GROUP"
    80         I FILE=811.2 Q "REMINDER TAXONOMY"
    81         I FILE=130 Q "SURGERY"
    82         I FILE=8925 Q "NOTES"
    83         I FILE=690 Q "MEDICINE"
    84         Q ""
    85         ;
    86 FILECHK(FILES)  ;
    87         ; get parameter string of excluded files
    88         N CHECK,NUM,ORSRV,VAL
    89         S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
    90         S CHECK=$$XGET^ORWGAPIX("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORWG GRAPH EXCLUDE DATA TYPE",1,"I")
    91         S CHECK=CHECK_";"
    92         S NUM=0
    93         F  S NUM=$O(FILES(NUM)) Q:NUM<1  D
    94         . S VAL=FILES(NUM)
    95         . S VAL=$P(VAL,U)_";"
    96         . I CHECK[VAL K FILES(NUM)
    97         Q
    98         ;
    99 GETFILES(FILES) ;
    100         ; file #^file name^graph type^lookup file^lookup global^lookup index^prefix^abbrev^hint format
    101         ; commenting out a line setting FILES will inactivate that type
    102         S FILES(1)="63^LAB TESTS^1^60^LAB(60,^B^^CH^~  ~units~flag~|"
    103         S FILES(2)="120.5^VITALS^1^120.51^GMRD(120.51,^B^^VSD^~  ~"
    104         S FILES(3)="52^MEDICATION,OUTPATIENT^3^50^PSDRUG(^B^^RXOP^~  ~"
    105         S FILES(4)="55^MEDICATION,INPATIENT^3^50^PSDRUG(^B^^RXUD^~  ~"
    106         S FILES(5)="70^RADIOLOGY EXAMS^2^71^RAMIS(71,^B^rad^II^~  ~"
    107         S FILES(6)="9000010.11^IMMUNIZATIONS^2^9999999.14^AUTTIMM(^B^imm^IM^~  ~"
    108         S FILES(7)="9000010.12^SKIN TESTS^2^9999999.28^AUTTSK(^B^skin^ST^~  ~"
    109         S FILES(8)="9000010.13^EXAMS^2^9999999.15,^AUTTEXAM(^B^exam^EXAM^~  ~"
    110         S FILES(9)="9000010.18^PROCEDURES^2^81^ICPT(^C^proc^CPT^~  ~"
    111         S FILES(10)="9000011^PROBLEMS^2^80^ICD9(^B^prob^PLL^~  ~" ;***
    112         S FILES(11)="9000010.23^HEALTH FACTORS^2^9999999.64^AUTTHF(,^B^hf^HF^~  ~"
    113         S FILES(12)="9000010.07^PURPOSE OF VISIT^2^80^ICD9(^B^pov^OD^"
    114         S FILES(13)="9000010.16^PATIENT EDUCATION^2^9999999.09^AUTTEDT(^B^edu^ED^~  ~"
    115         S FILES(14)="601.2^MENTAL HEALTH^2^601^YTT(601,^B^mh^MHPE^~  ~"
    116         S FILES(15)="100^ORDERS^2^101.43^ORD(101.43,^B^order^ORC^~  ~"
    117         S FILES(16)="45OP^REGISTRATION OP/PROC^2^*^^^op^PRC^~  ~"
    118         S FILES(17)="45DX^REGISTRATION DX^2^*^^^dx^DD^~  ~"
    119         S FILES(18)="63AP^ANATOMIC PATHOLOGY^2^*^^^ap^SP^~  ~"
    120         S FILES(19)="63MI^MICROBIOLOGY^2^*^^^micro^MIC^~  ~"
    121         S FILES(20)="9000010^VISITS^3^44^SC(^B^^CVP^~  ~"
    122         S FILES(21)="405^ADMISSIONS^3^*^^^^ADC^~  ~"
    123         S FILES(23)="53.79^MEDICATION,BCMA^2^50.7^PS(50.7,^B^^BCMA^~  ~"
    124         S FILES(24)="130^SURGERY^2^81^ICPT(^C^surg^SR^~  ~"
    125         S FILES(25)="8925^NOTES^2^*^^^note^CNB^~  ~"
    126         S FILES(27)="120.8^ALLERGIES^2^*^^^allg^ADR^~  ~"
    127         S FILES(28)="63BB^BLOOD BANK^2^66^LAB(66,^B^bb^BT^~  ~"
    128         ;S FILES(29)="9999911^PROBLEMS-DURATION^3^80^ICD9(^B^prob^PLL^~  ~" ;***
    129         S FILES(30)="55NVA^MEDICATION,NON-VA^3^50.7^PS(50.7,^B^^RXNV^~  ~"
    130         S FILES(31)="690^MEDICINE^2^*^^^med^MEDF^~  ~"
    131         S FILES(2000)="811.2^Reminder Taxonomy"
    132         S FILES(3000)="50.605^Drug Class"
    133         Q
    134         ;
    135 TYPES(TYPES,DFN,SUB,TMP)        ; from ORWGAPI
    136         N CNT,FILES,ITEM,MEDARRAY,NUM,OK,SEQ K FILES,MEDARRAY
    137         S TMP=$G(TMP)
    138         D GETFILES(.FILES)
    139         D FILECHK(.FILES)
    140         I SUB D
    141         . I $D(FILES(18)) D
    142         .. S FILES(1801)="63AP;O^AP: Organ"
    143         .. S FILES(1802)="63AP;T^AP: Test"
    144         .. S FILES(1803)="63AP;D^AP: Disease"
    145         .. S FILES(1804)="63AP;I^AP: ICD9"
    146         .. S FILES(1805)="63AP;E^AP: Etiology"
    147         .. S FILES(1806)="63AP;F^AP: Function"
    148         .. S FILES(1807)="63AP;P^AP: Procedure"
    149         .. S FILES(1808)="63AP;M^AP: Morphology"
    150         .. S FILES(1809)="63AP;S^AP: Specimen"
    151         . I $D(FILES(19)) D
    152         .. S FILES(1901)="63MI;A^Microbiology: Antibiotic"
    153         .. S FILES(1902)="63MI;T^Microbiology: Test"
    154         .. S FILES(1903)="63MI;S^Microbiology: Specimen"
    155         .. S FILES(1904)="63MI;O^Microbiology: Organism"
    156         .. ;S FILES(1905)="63MI;M^Microbiology: TB Drug"
    157         I 'SUB D
    158         . K FILES(2000)
    159         . K FILES(3000)
    160         I DFN D
    161         . I '$L($O(^PXRMINDX(63,"PI",DFN,""))) K FILES(1)
    162         . I '$L($O(^PXRMINDX(120.5,"PI",DFN,""))) K FILES(2)
    163         . I '$L($O(^PXRMINDX(52,"PI",DFN,""))) K FILES(3)
    164         . I '$L($O(^PXRMINDX(55,"PI",DFN,""))) K FILES(4)
    165         . I '$L($O(^PXRMINDX(70,"PI",DFN,""))) K FILES(5)
    166         . I '$L($O(^PXRMINDX(9000010.11,"PI",DFN,""))) K FILES(6)
    167         . I '$L($O(^PXRMINDX(9000010.12,"PI",DFN,""))) K FILES(7)
    168         . I '$L($O(^PXRMINDX(9000010.13,"PI",DFN,""))) K FILES(8)
    169         . I '$L($O(^PXRMINDX(9000010.18,"PPI",DFN,""))) K FILES(9)
    170         . I '$L($O(^PXRMINDX(9000011,"PSPI",DFN,""))) K FILES(10),FILES(29)
    171         . I '$L($O(^PXRMINDX(9000010.23,"PI",DFN,""))) K FILES(11)
    172         . I '$L($O(^PXRMINDX(9000010.07,"PPI",DFN,""))) K FILES(12)
    173         . I '$L($O(^PXRMINDX(9000010.16,"PI",DFN,""))) K FILES(13)
    174         . I '$L($O(^PXRMINDX(601.2,"PI",DFN,""))) K FILES(14)
    175         . I '$L($O(^PXRMINDX(100,"PI",DFN,""))) K FILES(15)
    176         . I '$L($O(^PXRMINDX(45,"ICD0","PNI",DFN,0))) K FILES(16)
    177         . I '$L($O(^PXRMINDX(45,"ICD9","PNI",DFN,0))) K FILES(17)
    178         . I $E($O(^PXRMINDX(63,"PI",DFN,"A")))'="A" K FILES(18) D
    179         .. F NUM=1:1:9 K FILES(180+NUM)
    180         . I $E($O(^PXRMINDX(63,"PI",DFN,"M")))'="M" K FILES(19) D
    181         .. F NUM=1:1:5 K FILES(190+NUM)
    182         . I '$$VISITX^ORWGAPIA(DFN) K FILES(20)
    183         . I '$$ADMITX^ORWGAPIA(DFN) K FILES(21)
    184         . I '$$NVAX^ORWGAPIC(DFN) K FILES(22),FILES(30)
    185         . I '$$BCMAX^ORWGAPIC(DFN) K FILES(23)
    186         . I '$$SURGX^ORWGAPIA(DFN) K FILES(24)
    187         . I '$$NOTEX^ORWGAPIA(DFN) K FILES(25)
    188         . I '$$ALLERGYX^ORWGAPIA(DFN) K FILES(27)
    189         . I '$$BBX^ORWGAPIB(DFN) K FILES(28)
    190         . S OK=0
    191         . D MEDICINE^ORWGAPIA(.MEDARRAY,DFN)
    192         . I $O(MEDARRAY(0)) S OK=1
    193         . I 'OK K FILES(31)
    194         S CNT=0,SEQ=0
    195         F  S SEQ=$O(FILES(SEQ)) Q:SEQ<1  D
    196         . S CNT=CNT+1
    197         . I TMP S ^TMP(TYPES,$J,CNT)=FILES(SEQ)
    198         . I 'TMP S TYPES(CNT)=FILES(SEQ)
    199         Q
    200         ;
     1ORWGAPIT ; SLC/STAFF - Graph Item Types ;11/20/06  08:58
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
     3 ;
     4COMPTYPE(FILE) ; $$(file) -> hs component abbrv   - from ORWGAPID
     5 N COMP,COMPNAME,COMPS,NUM,OK K COMPS
     6 S COMPNAME=$$COMPNAME(FILE)_"]"
     7 D COMP^ORWRP2(.COMPS)
     8 S COMP=""
     9 S OK=0
     10 S NUM=0
     11 D
     12 . F  S NUM=$O(COMPS(NUM)) Q:NUM<1  D  I OK Q
     13 .. S COMP=COMPS(NUM)
     14 .. I COMP[COMPNAME,COMPNAME=$P($P(COMP,U,2),"[",2) S OK=1
     15 Q COMP
     16 ;
     17COMPNAME(FILE) ; $$(file) -> hs component abbrv
     18 I FILE=63 Q "CH"
     19 I FILE=120.5 Q "VSD"
     20 I FILE=120.8 Q "ADR"
     21 I FILE=52 Q "RXOP"
     22 I FILE=55 Q "RXUD"
     23 I FILE=70 Q "II"
     24 I FILE=9000010.11 Q "IM"
     25 I FILE=9000010.12 Q "ST"
     26 I FILE=9000010.13 Q "EXAM"
     27 I FILE=9000010.18 Q "CPT"
     28 I FILE=9000011 Q "PLL"
     29 I FILE=9999911 Q "PLL"
     30 I FILE=9000010.23 Q "HF"
     31 I FILE=9000010.07 Q "OD"
     32 I FILE=9000010.16 Q "ED"
     33 I FILE=601.2 Q "MHPE"
     34 I FILE=100 Q "ORC"
     35 I FILE="45OP" Q "PRC"
     36 I FILE="45DX" Q "DD"
     37 I FILE="63AP" Q "SP"
     38 I FILE="63BB" Q "BT"
     39 I FILE="63MI" Q "MIC"
     40 I FILE=9000010 Q "CVP"
     41 I FILE=405 Q "ADC"
     42 I FILE="55NVAE" Q "RXNV"
     43 I FILE="55NVA" Q "RXNV"
     44 I FILE=53.79 Q "BCMA"
     45 I FILE=130 Q "SR"
     46 I FILE=8925 Q "CNB"
     47 I FILE=9000010.15 Q "TP"
     48 I FILE=690 Q "MEDF"
     49 Q ""
     50 ;
     51FILENAME(FILE) ; $$(file) -> filename   - from ORWGAPIP
     52 I FILE=63 Q "LAB TESTS"
     53 I FILE=120.5 Q "VITALS"
     54 I FILE=120.8 Q "ALLERGIES"
     55 I FILE=52 Q "MEDICATION,OUTPATIENT"
     56 I FILE=55 Q "MEDICATION,INPATIENT"
     57 I FILE=70 Q "RADIOLOGY EXAMS"
     58 I FILE=9000010.11 Q "IMMUNIZATIONS"
     59 I FILE=9000010.12 Q "SKIN TESTS"
     60 I FILE=9000010.13 Q "EXAMS"
     61 I FILE=9000010.18 Q "PROCEDURES"
     62 I FILE=9000011 Q "PROBLEMS"
     63 I FILE=9999911 Q "PROBLEMS-DURATION" ;**************
     64 I FILE=9000010.23 Q "HEALTH FACTORS"
     65 I FILE=9000010.07 Q "PURPOSE OF VISIT"
     66 I FILE=9000010.16 Q "PATIENT EDUCATION"
     67 I FILE=601.2 Q "MENTAL HEALTH"
     68 I FILE=100 Q "ORDERS"
     69 I FILE="45OP" Q "REGISTRATION OP/PROC"
     70 I FILE="45DX" Q "REGISTRATION DX"
     71 I FILE="63AP" Q "ANATOMIC PATHOLOGY"
     72 I FILE="63BB" Q "BLOOD PRODUCTS"
     73 I FILE="63MI" Q "MICROBIOLOGY"
     74 I FILE=9000010 Q "VISITS"
     75 I FILE=405 Q "ADMISSIONS"
     76 I FILE="55NVAE" Q "MEDICATION,NON-VA-EVENT" ;*****
     77 I FILE="55NVA" Q "MEDICATION,NON-VA"
     78 I FILE=53.79 Q "MEDICATION,BCMA"
     79 I FILE=50.605 Q "DRUG CLASS"
     80 I FILE=68 Q "LAB ACC AREA"
     81 I FILE=8925.1 Q "NOTE TITLE"
     82 I FILE=100.98 Q "ORDER DISPLAY GROUP"
     83 I FILE=811.2 Q "REMINDER TAXONOMY"
     84 I FILE=130 Q "SURGERY"
     85 I FILE=8925 Q "NOTES"
     86 I FILE=9000010.15 Q "TREATMENTS"
     87 I FILE=690 Q "MEDICINE"
     88 Q ""
     89 ;
     90FILECHK(FILES) ;
     91 ; get parameter string of excluded files
     92 N CHECK,NUM,ORSRV,VAL
     93 S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
     94 S CHECK=$$XGET^ORWGAPIX("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORWG GRAPH EXCLUDE DATA TYPE",1,"I")
     95 S CHECK=CHECK_";"
     96 S NUM=0
     97 F  S NUM=$O(FILES(NUM)) Q:NUM<1  D
     98 . S VAL=FILES(NUM)
     99 . S VAL=$P(VAL,U)_";"
     100 . I CHECK[VAL K FILES(NUM)
     101 Q
     102 ;
     103GETFILES(FILES) ;
     104 ; file #^file name^graph type^lookup file^lookup global^lookup index
     105 ; commenting out a line setting FILES will inactivate that type
     106 S FILES(1)="63^LAB TESTS^1^60^LAB(60,^B^^CH^"
     107 S FILES(2)="120.5^VITALS^1^120.51^GMRD(120.51,^B^^VSD^"
     108 S FILES(3)="52^MEDICATION,OUTPATIENT^3^50^PSDRUG(^B^^RXOP^"
     109 S FILES(4)="55^MEDICATION,INPATIENT^3^50^PSDRUG(^B^^RXUD^"
     110 S FILES(5)="70^RADIOLOGY EXAMS^2^71^RAMIS(71,^B^rad^II^"
     111 S FILES(6)="9000010.11^IMMUNIZATIONS^2^9999999.14^AUTTIMM(^B^imm^IM^"
     112 S FILES(7)="9000010.12^SKIN TESTS^2^9999999.28^AUTTSK(^B^skin^ST^"
     113 S FILES(8)="9000010.13^EXAMS^2^9999999.15,^AUTTEXAM(^B^exam^EXAM^"
     114 S FILES(9)="9000010.18^PROCEDURES^2^81^ICPT(^C^proc^CPT^"
     115 S FILES(10)="9000011^PROBLEMS^2^80^ICD9(^B^prob^PLL^" ;***
     116 S FILES(11)="9000010.23^HEALTH FACTORS^2^9999999.64^AUTTHF(,^B^hf^HF^"
     117 S FILES(12)="9000010.07^PURPOSE OF VISIT^2^80^ICD9(^B^pov^OD^"
     118 S FILES(13)="9000010.16^PATIENT EDUCATION^2^9999999.09^AUTTEDT(^B^edu^ED^"
     119 S FILES(14)="601.2^MENTAL HEALTH^2^601^YTT(601,^B^mh^MHPE^"
     120 S FILES(15)="100^ORDERS^2^101.43^ORD(101.43,^B^order^ORC^"
     121 S FILES(16)="45OP^REGISTRATION OP/PROC^2^*^^^op^PRC^"
     122 S FILES(17)="45DX^REGISTRATION DX^2^*^^^dx^DD^"
     123 S FILES(18)="63AP^ANATOMIC PATHOLOGY^2^*^^^ap^SP^"
     124 S FILES(19)="63MI^MICROBIOLOGY^2^*^^^micro^MIC^"
     125 S FILES(20)="9000010^VISITS^3^44^SC(^B^^CVP^"
     126 S FILES(21)="405^ADMISSIONS^3^*^^^^ADC^"
     127 ;S FILES(22)="55NVAE^MEDICATION,NON-VA-EVENT^2^50.7^PS(50.7,^B^^RXNV^"
     128 S FILES(23)="53.79^MEDICATION,BCMA^2^50.7^PS(50.7,^B^^BCMA^"
     129 S FILES(24)="130^SURGERY^2^81^ICPT(^C^surg^SR^"
     130 S FILES(25)="8925^NOTES^2^*^^^note^CNB^"
     131 ;S FILES(26)="9000010.15^TREATMENTS^2^9999999.17,^AUTTTRT(^B^treat^TP^"
     132 S FILES(27)="120.8^ALLERGIES^2^*^^^allg^ADR^"
     133 S FILES(28)="63BB^BLOOD BANK^2^66^LAB(66,^B^bb^BT^"
     134 ;S FILES(29)="9999911^PROBLEMS-DURATION^3^80^ICD9(^B^prob^PLL^" ;***
     135 S FILES(30)="55NVA^MEDICATION,NON-VA^3^50.7^PS(50.7,^B^^RXNV^"
     136 S FILES(31)="690^MEDICINE^2^*^^^med^MEDF^"
     137 S FILES(2000)="811.2^Reminder Taxonomy"
     138 S FILES(3000)="50.605^Drug Class"
     139 Q
     140 ;
     141TYPES(TYPES,DFN,SUB,TMP) ; from ORWGAPI
     142 N CNT,FILES,ITEM,MEDARRAY,NUM,OK,SEQ K FILES,MEDARRAY
     143 S TMP=$G(TMP)
     144 D GETFILES(.FILES)
     145 D FILECHK(.FILES)
     146 I SUB D
     147 . I $D(FILES(18)) D
     148 .. S FILES(1801)="63AP;O^AP: Organ"
     149 .. S FILES(1802)="63AP;T^AP: Test"
     150 .. S FILES(1803)="63AP;D^AP: Disease"
     151 .. S FILES(1804)="63AP;I^AP: ICD9"
     152 .. S FILES(1805)="63AP;E^AP: Etiology"
     153 .. S FILES(1806)="63AP;F^AP: Function"
     154 .. S FILES(1807)="63AP;P^AP: Procedure"
     155 .. S FILES(1808)="63AP;M^AP: Morphology"
     156 .. S FILES(1809)="63AP;S^AP: Specimen"
     157 . I $D(FILES(19)) D
     158 .. S FILES(1901)="63MI;A^Microbiology: Antibiotic"
     159 .. S FILES(1902)="63MI;T^Microbiology: Test"
     160 .. S FILES(1903)="63MI;S^Microbiology: Specimen"
     161 .. S FILES(1904)="63MI;O^Microbiology: Organism"
     162 .. ;S FILES(1905)="63MI;M^Microbiology: TB Drug"
     163 I 'SUB D
     164 . K FILES(2000)
     165 . K FILES(3000)
     166 I DFN D
     167 . I '$L($O(^PXRMINDX(63,"PI",DFN,""))) K FILES(1)
     168 . I '$L($O(^PXRMINDX(120.5,"PI",DFN,""))) K FILES(2)
     169 . I '$L($O(^PXRMINDX(52,"PI",DFN,""))) K FILES(3)
     170 . I '$L($O(^PXRMINDX(55,"PI",DFN,""))) K FILES(4)
     171 . I '$L($O(^PXRMINDX(70,"PI",DFN,""))) K FILES(5)
     172 . I '$L($O(^PXRMINDX(9000010.11,"PI",DFN,""))) K FILES(6)
     173 . I '$L($O(^PXRMINDX(9000010.12,"PI",DFN,""))) K FILES(7)
     174 . I '$L($O(^PXRMINDX(9000010.13,"PI",DFN,""))) K FILES(8)
     175 . I '$L($O(^PXRMINDX(9000010.18,"PPI",DFN,""))) K FILES(9)
     176 . I '$L($O(^PXRMINDX(9000011,"PSPI",DFN,""))) K FILES(10),FILES(29)
     177 . I '$L($O(^PXRMINDX(9000010.23,"PI",DFN,""))) K FILES(11)
     178 . I '$L($O(^PXRMINDX(9000010.07,"PPI",DFN,""))) K FILES(12)
     179 . I '$L($O(^PXRMINDX(9000010.16,"PI",DFN,""))) K FILES(13)
     180 . I '$L($O(^PXRMINDX(601.2,"PI",DFN,""))) K FILES(14)
     181 . I '$L($O(^PXRMINDX(100,"PI",DFN,""))) K FILES(15)
     182 . I '$L($O(^PXRMINDX(45,"ICD0","PNI",DFN,0))) K FILES(16)
     183 . I '$L($O(^PXRMINDX(45,"ICD9","PNI",DFN,0))) K FILES(17)
     184 . I $E($O(^PXRMINDX(63,"PI",DFN,"A")))'="A" K FILES(18) D
     185 .. F NUM=1:1:9 K FILES(180+NUM)
     186 . I $E($O(^PXRMINDX(63,"PI",DFN,"M")))'="M" K FILES(19) D
     187 .. F NUM=1:1:5 K FILES(190+NUM)
     188 . I '$$VISITX^ORWGAPIA(DFN) K FILES(20)
     189 . I '$$ADMITX^ORWGAPIA(DFN) K FILES(21)
     190 . I '$$NVAX^ORWGAPIA(DFN) K FILES(22),FILES(30)
     191 . I '$$BCMAX^ORWGAPIA(DFN) K FILES(23)
     192 . I '$$SURGX^ORWGAPIA(DFN) K FILES(24)
     193 . I '$$NOTEX^ORWGAPIA(DFN) K FILES(25)
     194 . I '$$TREATX^ORWGAPIA(DFN) K FILES(26)
     195 . I '$$ALLERGYX^ORWGAPIA(DFN) K FILES(27)
     196 . I '$$BBX^ORWGAPIB(DFN) K FILES(28)
     197 . S OK=0
     198 . D MEDICINE^ORWGAPIA(.MEDARRAY,DFN)
     199 . I $O(MEDARRAY(0)) S OK=1
     200 . I 'OK K FILES(31)
     201 S CNT=0,SEQ=0
     202 F  S SEQ=$O(FILES(SEQ)) Q:SEQ<1  D
     203 . S CNT=CNT+1
     204 . I TMP S ^TMP(TYPES,$J,CNT)=FILES(SEQ)
     205 . I 'TMP S TYPES(CNT)=FILES(SEQ)
     206 Q
     207 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIU.m

    r613 r623  
    1 ORWGAPIU        ; SLC/STAFF - Graph API Utilities ;3/17/08  10:27
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 EVALUE(VAL,FILE,FIELD)  ; $$(internal value,file,field) -> external value or ""
    5         ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR
    6         I VAL="" Q ""
    7         S FIELD=$G(FIELD,.01)
    8         I $E(FILE,1,2)=63 Q $$LABNAME^ORWGAPIC(VAL)
    9         I FILE="63AP;I" Q $$ICD9^ORWGAPIA(VAL)
    10         I FILE="45DX" Q $$ICD9^ORWGAPIA(VAL)
    11         I FILE="45OP" Q $$ICD0^ORWGAPIA(VAL)
    12         I FILE="45;ICD9" Q $$ICD9^ORWGAPIA(VAL)
    13         I FILE="45;ICD0" Q $$ICD0^ORWGAPIA(VAL)
    14         I FIELD=.01,'$L(VAL) Q ""
    15         I FILE=9000010.07 Q $$ICD9^ORWGAPIA(VAL)
    16         I FILE=9000010.18 Q $$ICPT^ORWGAPIA(VAL)
    17         I FILE=9000011 Q $$ICD9^ORWGAPIA(VAL)
    18         I FILE=9999911 Q $$ICD9^ORWGAPIA(VAL)
    19         I FILE=130 Q $$ICPT^ORWGAPIA(VAL)
    20         I FILE=120.8 Q $$ALLG^ORWGAPIA(VAL)
    21         I FILE=50.605 Q $$DC^ORWGAPIC(VAL)
    22         I FILE=68 Q $$AA^ORWGAPIC(VAL)
    23         I FILE=811.2 Q $$TAX^ORWGAPIA(VAL)
    24         D
    25         . I FILE=52 S FIELD=6 Q
    26         . I FILE=53.79 S FIELD=.08 Q
    27         . I FILE=55 S FILE=55.07 Q
    28         . I FILE="55NVA" S FILE=55.05 Q
    29         . I FILE=70 S FILE=70.03,FIELD=2 Q
    30         . I FILE=100 S FILE=100.001 Q
    31         . I FILE=120.5 S FIELD=.03 Q
    32         . I FILE=601.2 S FILE=601.21 Q
    33         Q $$EXT^ORWGAPIX(VAL,FILE,FIELD)
    34         ;
    35 FILE(FILE,REF,XREF,SCREEN)      ; from ORWGAPI
    36         S REF="",SCREEN="I 1",XREF="B"
    37         I FILE="" Q
    38         D
    39         . I FILE="45DX" S REF=$$GBLREF(80),XREF="AB" Q
    40         . I FILE="45OP" S REF=$$GBLREF(80.1),XREF="AB" Q
    41         . I FILE=50.605 S REF=$$GBLREF(50.605),XREF="C" Q
    42         . I FILE=52 S REF=$$GBLREF(50) Q
    43         . I FILE=53.79 S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)'=1" Q
    44         . I FILE=55 S REF=$$GBLREF(50) Q
    45         . I FILE="55NVA" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q
    46         . I FILE=63 S REF=$$GBLREF(60),SCREEN="I $L($P(ZERO,U,5)),""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""CH""" Q
    47         . I FILE="63AP" S REF=$$GBLREF(60),SCREEN="I 0" Q
    48         . I FILE="63AP;D" S REF=$$GBLREF(61.4) Q
    49         . I FILE="63AP;E" S REF=$$GBLREF(61.2) Q
    50         . I FILE="63AP;F" S REF=$$GBLREF(61.3) Q
    51         . I FILE="63AP;I" S REF=$$GBLREF(80),XREF="AB" Q
    52         . I FILE="63AP;M" S REF=$$GBLREF(61.1) Q
    53         . I FILE="63AP;O" S REF=$$GBLREF(61) Q
    54         . I FILE="63AP;P" S REF=$$GBLREF(61.5) Q
    55         . I FILE="63AP;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),(($P(ZERO,U,4)=""CY"")!($P(ZERO,U,4)=""SP"")!($P(ZERO,U,4)=""EM"")!($P(ZERO,U,4)=""AU""))" Q
    56         . I FILE="63BB" S REF=$$GBLREF(66),SCREEN="I $P(ZERO,U,15)=1" Q
    57         . I FILE="63MI" S REF=$$GBLREF(60),SCREEN="I 0" Q
    58         . I FILE="63MI;A" S REF=$$GBLREF(62.06) Q
    59         . I FILE="63MI;M" S REF=$$GBLREF(60) Q  ; mycobacteria not currently used
    60         . I FILE="63MI;O" S REF=$$GBLREF(61.2),SCREEN="I $L($P(ZERO,U,5)),""BFPMV""[$P(ZERO,U,5)" Q
    61         . I FILE="63MI;S" S REF=$$GBLREF(61) Q
    62         . I FILE="63MI;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""MI""" Q
    63         . I FILE=70 S REF=$$GBLREF(71) Q
    64         . I FILE=100 S REF=$$GBLREF(101.43) Q
    65         . I FILE=120.5 S REF=$$GBLREF(120.51),SCREEN="I ""BP^P^T^R^P^HT^WT^CVP^CG^PO2^PN""[$P(ZERO,U,2)" Q
    66         . ;I FILE=120.8 S REF=$$GBLREF(120.83) Q
    67         . I FILE=130 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q
    68         . I FILE=405 S REF=$$GBLREF(44),SCREEN="I 0" Q
    69         . I FILE=601.2 S REF=$$GBLREF(601) Q
    70         . I FILE=690 S REF=$$GBLREF(697.2),XREF="BA" Q
    71         . I FILE=811.2 S REF=$$GBLREF(811.2),SCREEN="I $P(ZERO,U,6)'=1" Q
    72         . I FILE=8925 S REF=$$GBLREF(8925.1),SCREEN="I $P(ZERO,U,4)=""DOC""" Q
    73         . I FILE=9000010 S REF=$$GBLREF(44) Q
    74         . I FILE=9000010.07 S REF=$$GBLREF(80),XREF="AB" Q
    75         . I FILE=9000010.11 S REF=$$GBLREF(9999999.14),SCREEN="I $P(ZERO,U,7)'=1" Q
    76         . I FILE=9000010.12 S REF=$$GBLREF(9999999.28),SCREEN="I $P(ZERO,U,3)'=1" Q
    77         . I FILE=9000010.13 S REF=$$GBLREF(9999999.15),SCREEN="I $P(ZERO,U,4)'=1" Q
    78         . I FILE=9000010.16 S REF=$$GBLREF(9999999.09),SCREEN="I $P(ZERO,U,3)'=1" Q
    79         . I FILE=9000010.18 S REF=$$GBLREF(81),XREF="BA",SCREEN="I '$P(ZERO,U,4)" Q
    80         . I FILE=9000010.23 S REF=$$GBLREF(9999999.64),SCREEN="I $P(ZERO,U,10)=""F"",$P(ZERO,U,11)'=1" Q
    81         . I FILE=9000011 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q
    82         . I FILE=9999911 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q
    83         I $E(REF)'="^" S REF=""
    84         S REF=REF  ;_""""_XREF_""")"
    85         Q
    86         ;
    87 GBLREF(FN)      ; $$(file#) -> global reference
    88         Q $$GBLREF^ORWGAPIX($G(FN))
    89         ;
    90 INISET  ; postinit, set initial public graph setting  - from ORY215, ORY243
    91         D INISET^ORWGAPIP
    92         D RESOURCE^ORWGTASK
    93         Q
    94         ;
    95 ITEMPRFX(ITEM)  ; $$(item) -> item prefix   - from ORWGAPI1
    96         N ABBREV,PREFIX
    97         S PREFIX=""
    98         S ABBREV=$P(ITEM,";",2)
    99         I $E(ITEM)="A" D  Q PREFIX
    100         . I ABBREV="T" S PREFIX="TEST" Q
    101         . I ABBREV="S" S PREFIX="SPECIMEN" Q
    102         . I ABBREV="O" S PREFIX="ORGAN" Q
    103         . I ABBREV="M" S PREFIX="MORPHOLOGY" Q
    104         . I ABBREV="E" S PREFIX="ETIOLOGY" Q
    105         . I ABBREV="D" S PREFIX="DISEASE" Q
    106         . I ABBREV="P" S PREFIX="PROCEDURE" Q
    107         . I ABBREV="F" S PREFIX="FUNCTION" Q
    108         . I ABBREV="I" S PREFIX="ICD9" Q
    109         I $E(ITEM)="B" Q "BLOOD COMPONENT"
    110         I $E(ITEM)="M" D  Q PREFIX
    111         . I ABBREV="T" S PREFIX="TEST" Q
    112         . I ABBREV="S" S PREFIX="SPECIMEN" Q
    113         . I ABBREV="O" S PREFIX="ORGANISM" Q
    114         . I ABBREV="A" S PREFIX="ANTIBIOTIC" Q
    115         . I ABBREV="M" S PREFIX="TB ANTIBIOTIC" Q
    116         Q PREFIX
    117         ;
     1ORWGAPIU ; SLC/STAFF - Graph API Utilities ;8/19/06  15:20
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
     3 ;
     4EVALUE(VAL,FILE,FIELD) ; $$(internal value,file,field) -> external value or ""
     5 ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR
     6 I VAL="" Q ""
     7 S FIELD=$G(FIELD,.01)
     8 I $E(FILE,1,2)=63 Q $$LABNAME^ORWGAPIA(VAL)
     9 I FILE="63AP;I" Q $$ICD9^ORWGAPIA(VAL)
     10 I FILE="45DX" Q $$ICD9^ORWGAPIA(VAL)
     11 I FILE="45OP" Q $$ICD0^ORWGAPIA(VAL)
     12 I FILE="45;ICD9" Q $$ICD9^ORWGAPIA(VAL)
     13 I FILE="45;ICD0" Q $$ICD0^ORWGAPIA(VAL)
     14 I FIELD=.01,'$L(VAL) Q ""
     15 I FILE=9000010.07 Q $$ICD9^ORWGAPIA(VAL)
     16 I FILE=9000010.18 Q $$ICPT^ORWGAPIA(VAL)
     17 I FILE=9000011 Q $$ICD9^ORWGAPIA(VAL)
     18 I FILE=9999911 Q $$ICD9^ORWGAPIA(VAL)
     19 I FILE=130 Q $$ICPT^ORWGAPIA(VAL)
     20 I FILE=120.8 Q $$ALLG^ORWGAPIA(VAL)
     21 I FILE=50.605 Q $$DC^ORWGAPIA(VAL)
     22 I FILE=68 Q $$AA^ORWGAPIA(VAL)
     23 I FILE=811.2 Q $$TAX^ORWGAPIA(VAL)
     24 D
     25 . I FILE=52 S FIELD=6 Q
     26 . I FILE=53.79 S FIELD=.08 Q
     27 . I FILE=55 S FILE=55.07 Q
     28 . I FILE="55NVAE" S FILE=55.05 Q
     29 . I FILE="55NVA" S FILE=55.05 Q
     30 . I FILE=70 S FILE=70.03,FIELD=2 Q
     31 . I FILE=100 S FILE=100.001 Q
     32 . I FILE=120.5 S FIELD=.03 Q
     33 . I FILE=601.2 S FILE=601.21 Q
     34 Q $$EXT^ORWGAPIX(VAL,FILE,FIELD)
     35 ;
     36FILE(FILE,REF,XREF,SCREEN) ; from ORWGAPI
     37 S REF="",SCREEN="I 1",XREF="B"
     38 I FILE="" Q
     39 D
     40 . I FILE="45DX" S REF=$$GBLREF(80),XREF="AB" Q
     41 . I FILE="45OP" S REF=$$GBLREF(80.1),XREF="AB" Q
     42 . I FILE=50.605 S REF=$$GBLREF(50.605),XREF="C" Q
     43 . I FILE=52 S REF=$$GBLREF(50) Q
     44 . I FILE=53.79 S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)'=1" Q
     45 . I FILE=55 S REF=$$GBLREF(50) Q
     46 . I FILE="55NVAE" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q
     47 . I FILE="55NVA" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q
     48 . I FILE=63 S REF=$$GBLREF(60),SCREEN="I $L($P(ZERO,U,5)),""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""CH""" Q
     49 . I FILE="63AP" S REF=$$GBLREF(60),SCREEN="I 0" Q
     50 . I FILE="63AP;D" S REF=$$GBLREF(61.4) Q
     51 . I FILE="63AP;E" S REF=$$GBLREF(61.2) Q
     52 . I FILE="63AP;F" S REF=$$GBLREF(61.3) Q
     53 . I FILE="63AP;I" S REF=$$GBLREF(80),XREF="AB" Q
     54 . I FILE="63AP;M" S REF=$$GBLREF(61.1) Q
     55 . I FILE="63AP;O" S REF=$$GBLREF(61) Q
     56 . I FILE="63AP;P" S REF=$$GBLREF(61.5) Q
     57 . I FILE="63AP;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),(($P(ZERO,U,4)=""CY"")!($P(ZERO,U,4)=""SP"")!($P(ZERO,U,4)=""EM"")!($P(ZERO,U,4)=""AU""))" Q
     58 . I FILE="63BB" S REF=$$GBLREF(66),SCREEN="I $P(ZERO,U,15)=1" Q
     59 . I FILE="63MI" S REF=$$GBLREF(60),SCREEN="I 0" Q
     60 . I FILE="63MI;A" S REF=$$GBLREF(62.06) Q
     61 . I FILE="63MI;M" S REF=$$GBLREF(60) Q  ; mycobacteria not currently used
     62 . I FILE="63MI;O" S REF=$$GBLREF(61.2),SCREEN="I $L($P(ZERO,U,5)),""BFPMV""[$P(ZERO,U,5)" Q
     63 . I FILE="63MI;S" S REF=$$GBLREF(61) Q
     64 . I FILE="63MI;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""MI""" Q
     65 . I FILE=70 S REF=$$GBLREF(71) Q
     66 . I FILE=100 S REF=$$GBLREF(101.43) Q
     67 . I FILE=120.5 S REF=$$GBLREF(120.51),SCREEN="I ""BP^P^T^R^P^HT^WT^CVP^CG^PO2^PN""[$P(ZERO,U,2)" Q
     68 . ;I FILE=120.8 S REF=$$GBLREF(120.83) Q
     69 . I FILE=130 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q
     70 . I FILE=405 S REF=$$GBLREF(44),SCREEN="I 0" Q
     71 . I FILE=601.2 S REF=$$GBLREF(601) Q
     72 . I FILE=690 S REF=$$GBLREF(697.2),XREF="BA" Q
     73 . I FILE=811.2 S REF=$$GBLREF(811.2),SCREEN="I $P(ZERO,U,6)'=1" Q
     74 . I FILE=8925 S REF=$$GBLREF(8925.1),SCREEN="I $P(ZERO,U,4)=""DOC""" Q
     75 . I FILE=9000010 S REF=$$GBLREF(44) Q
     76 . I FILE=9000010.07 S REF=$$GBLREF(80),XREF="AB" Q
     77 . I FILE=9000010.11 S REF=$$GBLREF(9999999.14),SCREEN="I $P(ZERO,U,7)'=1" Q
     78 . I FILE=9000010.12 S REF=$$GBLREF(9999999.28),SCREEN="I $P(ZERO,U,3)'=1" Q
     79 . I FILE=9000010.13 S REF=$$GBLREF(9999999.15),SCREEN="I $P(ZERO,U,4)'=1" Q
     80 . I FILE=9000010.15 S REF=$$GBLREF(9999999.17),SCREEN="I $P(ZERO,U,4)'=1" Q
     81 . I FILE=9000010.16 S REF=$$GBLREF(9999999.09),SCREEN="I $P(ZERO,U,3)'=1" Q
     82 . I FILE=9000010.18 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q
     83 . I FILE=9000010.23 S REF=$$GBLREF(9999999.64),SCREEN="I $P(ZERO,U,10)=""F"",$P(ZERO,U,11)'=1" Q
     84 . I FILE=9000011 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q
     85 . I FILE=9999911 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q
     86 I $E(REF)'="^" S REF=""
     87 S REF=REF  ;_""""_XREF_""")"
     88 Q
     89 ;
     90GBLREF(FN) ; $$(file#) -> global reference
     91 Q $$GBLREF^ORWGAPIX($G(FN))
     92 ;
     93GENERIC(VAL,FROM,DIR,FILE,REF,XREF,SCREEN) ; Return a set of entries from xref in REF
     94 ; from ORWGAPI
     95 ; .VAL=returned list, FROM=text to $O from, DIR=$O direction,
     96 N CNT,IEN,NAME,NEXTNAME,NUM,OK,ROOT,ZERO S NUM=0,CNT=44 K VAL
     97 I FILE=405 Q
     98 S ROOT=""
     99 S FROM=$$UP^ORWGAPIX(FROM)
     100 I $E(REF,$L(REF))="," S ROOT=$E(REF,1,$L(REF)-1)_")"
     101 I $E(REF,$L(REF))="(" S ROOT=$P(REF,"(")
     102 I '$L(ROOT) Q
     103 S REF=REF_""""_XREF_""")"
     104 F  Q:NUM'<CNT  S FROM=$O(@REF@(FROM),DIR) Q:FROM=""  D
     105 . S IEN="" F  S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN  D
     106 .. I FILE=100,$O(@REF@(FROM,IEN,""))>0 Q
     107 .. S ZERO=$G(@ROOT@(IEN,0)) I '$L(ZERO) Q
     108 .. X SCREEN I '$T Q
     109 .. S NUM=NUM+1
     110 .. I FILE="45DX"!(FILE=9000010.07)!(FILE=9000011)!(FILE="63AP;I") D  Q
     111 ... S VAL(NUM)=FILE_U_IEN_U_$$ICD9^ORWGAPIA(IEN) Q
     112 .. I FILE="45OP" S VAL(NUM)=FILE_U_IEN_U_$$ICD0^ORWGAPIA(IEN) Q
     113 .. I FILE="55NVAE"!(FILE=53.79) S VAL(NUM)=FILE_U_IEN_U_$$POINAME^ORWGAPIA(IEN) Q
     114 .. I FILE="55NVA" S VAL(NUM)=FILE_U_IEN_U_$$POINAME^ORWGAPIA(IEN) Q
     115 .. I FILE=9000010.18 S VAL(NUM)=FILE_U_IEN_U_$$ICPT^ORWGAPIA(IEN) Q
     116 .. I FILE=130 S VAL(NUM)=FILE_U_IEN_U_$$ICPT^ORWGAPIA(IEN) Q
     117 .. S VAL(NUM)=FILE_U_IEN_U_FROM
     118 I FILE=120.5 D
     119 . S (NUM,OK)=0
     120 . F  S NUM=$O(VAL(NUM)) Q:NUM<1  D  Q:OK
     121 .. S NAME=$P(VAL(NUM),U,3)
     122 .. S NEXTNAME=$P($G(VAL(NUM+1)),U,3)
     123 .. I "BODY MASS INDEX"]NAME,NEXTNAME]"BODY MASS INDEX" D
     124 ... S OK=1
     125 ... S VAL(NUM+.5)="120.5^99999^BODY MASS INDEX"
     126 Q
     127 ;
     128INISET ; postinit, set initial public graph setting  - from ORY215
     129 D INISET^ORWGAPIP
     130 Q
     131 ;
     132ITEMPRFX(ITEM) ; $$(item) -> item prefix   - from ORWGAPI1
     133 N ABBREV,PREFIX
     134 S PREFIX=""
     135 S ABBREV=$P(ITEM,";",2)
     136 I $E(ITEM)="A" D  Q PREFIX
     137 . I ABBREV="T" S PREFIX="TEST" Q
     138 . I ABBREV="S" S PREFIX="SPECIMEN" Q
     139 . I ABBREV="O" S PREFIX="ORGAN" Q
     140 . I ABBREV="M" S PREFIX="MORPHOLOGY" Q
     141 . I ABBREV="E" S PREFIX="ETIOLOGY" Q
     142 . I ABBREV="D" S PREFIX="DISEASE" Q
     143 . I ABBREV="P" S PREFIX="PROCEDURE" Q
     144 . I ABBREV="F" S PREFIX="FUNCTION" Q
     145 . I ABBREV="I" S PREFIX="ICD9" Q
     146 I $E(ITEM)="B" Q "BLOOD COMPONENT"
     147 I $E(ITEM)="M" D  Q PREFIX
     148 . I ABBREV="T" S PREFIX="TEST" Q
     149 . I ABBREV="S" S PREFIX="SPECIMEN" Q
     150 . I ABBREV="O" S PREFIX="ORGANISM" Q
     151 . I ABBREV="A" S PREFIX="ANTIBIOTIC" Q
     152 . I ABBREV="M" S PREFIX="TB ANTIBIOTIC" Q
     153 Q PREFIX
     154 ;
     155OGROUP(OITEM) ; $$(orderable item) -> ien display group^display group   - from ORWGAPIR
     156 N IEN
     157 S IEN=+$P($G(^ORD(101.43,+$G(OITEM),0)),U,5)
     158 Q IEN_U_"order - "_$P($G(^ORD(100.98,IEN,0)),U)
     159 ;
     160RETURN(TMP,ITEMS) ; return TMP (0 use local, 1 use ^TMP(ITEMS,$J, where ITEMS is a namespaced string)
     161 ; from ORWGAPI, ORWGAPIP, ORWGAPIX
     162 N NMSP
     163 S NMSP=$G(ITEMS) K ITEMS S ITEMS=""
     164 S TMP=NMSP?1U1UN1.14UNP
     165 I TMP S ITEMS=NMSP
     166 Q
     167 ;
     168SETUP(DATA,RESULT,TMP,CNT) ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR, ORWGAPIX
     169 S CNT=CNT+1
     170 I TMP S ^TMP(DATA,$J,CNT)=RESULT
     171 I 'TMP S DATA(CNT)=RESULT
     172 Q
     173 ;
     174DATETFM(DATETIME) ; $$(external date/time) -> fm date/time else 0
     175 N DATE,DAY,FMDT,HOUR,MIN,SEC,TIME,YEAR
     176 S DATE=$P(DATETIME,"@"),TIME=$P(DATETIME,"@",2)
     177 S YEAR=$P(DATE,",",2) I $L(YEAR)'=4 Q 0
     178 S YEAR=YEAR-1700 I YEAR<270 Q 0
     179 S MONTH=$P(DATE," ")
     180 S MONTH=$$MTN(MONTH) I MONTH<1 Q 0
     181 I MONTH<10 S MONTH="0"_MONTH
     182 S DAY=$P(DATE," ",2),DAY=$P(DAY,",")
     183 I DAY<1 Q 0
     184 I DAY<10 S DAY="0"_DAY
     185 S HOUR=$P(TIME,":")
     186 S MIN=$P(TIME,":",2)
     187 S SEC=$P(TIME,":",3)
     188 S TIME=HOUR_MIN_SEC
     189 S FMDT=YEAR_MONTH_DAY
     190 I '$L(TIME) Q FMDT
     191 Q FMDT_"."_TIME
     192 ;
     193MTN(MONTH) ; $$(external month) -> month number
     194 N MONTHS,NUM
     195 I $L(MONTH)'=3 Q 0
     196 S MONTHS="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
     197 F NUM=1:1:13 I $P(MONTHS,U,NUM)=MONTH Q
     198 I NUM=13 Q 0
     199 Q NUM

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIX.m

    r613 r623  
    1 ORWGAPIX        ; SLC/STAFF - Graph External Calls ;9/29/06  11:49
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242
    3         ;
    4 DATE(X) ; $$(date/time) -> date/time
    5         N Y D ^%DT
    6         Q Y
    7 ENDIQ1(RESULTS,DIC,DR,DA,DIQ)   ; use file # for DIC
    8         N NUMDIC K RESULTS,^UTILITY("DIQ1",$J)
    9         Q:'$G(DIC)  Q:'$L(DR)  Q:'$G(DA)
    10         S NUMDIC=DIC
    11         D EN^DIQ1
    12         M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA)
    13         K ^UTILITY("DIQ1",$J)
    14         Q
    15 EXT(Y,FILE,FIELD)       ; $$(value,file,field) -> external value
    16         N C S C=$P($G(^DD(FILE,FIELD,0)),U,2) D Y^DIQ
    17         Q Y
    18 EXTERNAL(FILE,FIELD,FLAG,VAL)   ; $$(file,field,flag,internal value) -> external value
    19         Q $$EXTERNAL^DILFD(FILE,FIELD,FLAG,VAL)
    20 EXTNAME(IEN,FN) ; $$(ien,file#) -> external form of pointer
    21         N REF
    22         S REF=$G(^DIC(FN,0,"GL"))
    23         I $L(REF),+IEN Q $P($G(@(REF_IEN_",0)")),U)
    24         Q ""
    25 FILENM(FILENUM) ; $$(file#) -> file name
    26         N DIC,DO,NAME K DIC,DO
    27         S FILENUM=$$GBLREF(+$G(FILENUM))
    28         I '$L($G(FILENUM)) Q ""
    29         S DIC=FILENUM
    30         D DO^DIC1
    31         S NAME=$P(DO,U)
    32         Q NAME
    33 GETDATA(RESULTS,DIC,DR,DA,DIQ)  ; use file # for DIC
    34         N NUMDIC K RESULTS,^UTILITY("DIQ1",$J)
    35         Q:'$G(DIC)  Q:'$L(DR)  Q:'$G(DA)
    36         S NUMDIC=DIC
    37         D EN^DIQ1
    38         M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA)
    39         K ^UTILITY("DIQ1",$J)
    40         Q
    41 GBLREF(FILENUM) ; $$(file#) -> global reference
    42         I '$G(FILENUM) Q ""
    43         Q $$ROOT^DILFD(+FILENUM)
    44 INDEX(DIK,DA)   ; index entry in file   -  from ORWGAPIP
    45         D IX1^DIK
    46         Q
    47 XDEL(ENTITY,PARAM,NAME,ORERR)   ; from ORWGAPIP
    48         D DEL^XPAR(ENTITY,PARAM,NAME,.ORERR)
    49         Q
    50 XEN(ENTITY,PARAM,NAME,ORVAL,ORERR)      ; from ORWGAPIP
    51         D EN^XPAR(ENTITY,PARAM,NAME,.ORVAL,.ORERR)
    52         Q
    53 XENVAL(ORVALUES,PARAM)  ;
    54         D ENVAL^XPAR(.ORVALUES,PARAM)
    55         Q
    56 XGET(ENTITY,PARAM,INST,FORMAT)  ; $$(...) -> parameter values
    57         Q $$GET^XPAR(ENTITY,PARAM,INST,FORMAT)
    58 XGETLST(ORLIST,ENTITY,PARAM)    ; from ORWGAPIP
    59         D GETLST^XPAR(.ORLIST,ENTITY,PARAM)
    60         Q
    61 XGETLST1(ORLIST,ENTITY,PARAM,FORMAT,ORERR)      ; from ORWGAPIP
    62         D GETLST^XPAR(.ORLIST,ENTITY,PARAM,FORMAT,.ORERR)
    63         Q
    64 XGETWP(ORWP,ENTITY,PARAM,ALL)   ; from ORWGAPIP
    65         D GETWP^XPAR(.ORWP,ENTITY,PARAM,ALL)
    66         Q
    67         ; kernel functions
    68 FMADD(X,D,H,M,S)        ;
    69         Q $$FMADD^XLFDT(X,$G(D),$G(H),$G(M),$G(S))
    70 NOW()   ;
    71         Q $$NOW^XLFDT
    72 LOW(X)  ;
    73         Q $$LOW^XLFSTR(X)
    74 REPLACE(STRING,ORARRAY) ;
    75         Q $$REPLACE^XLFSTR(STRING,.ORARRAY)
    76 TRIM(X,F,V)     ;
    77         Q $$TRIM^XLFSTR(X,$G(F,"LR"),$G(V," "))
    78 UP(X)   ;
    79         Q $$UP^XLFSTR(X)
    80 BMIITEMS(ITEMS,CNT,TMP) ; from ORWGAPIR
    81         N BMI,NUM,REPLACE K REPLACE
    82         S REPLACE("WEIGHT")="BODY MASS INDEX"
    83         S BMI=""
    84         S NUM=0
    85         I 'TMP D
    86         . F  S NUM=$O(ITEMS(NUM)) Q:NUM<1  D
    87         .. I $P(ITEMS(NUM),U,2)=8 S $P(BMI,U)=1
    88         .. I $P(ITEMS(NUM),U,2)=9 S $P(BMI,U,2)=ITEMS(NUM)
    89         I TMP D
    90         . F  S NUM=$O(^TMP(ITEMS,$J,NUM)) Q:NUM<1  D
    91         .. I $P(^TMP(ITEMS,$J,NUM),U,2)=8 S $P(BMI,U)=1
    92         .. I $P(^TMP(ITEMS,$J,NUM),U,2)=9 S $P(BMI,U,2)=^TMP(ITEMS,$J,NUM)
    93         I BMI,$L(BMI)>3 D
    94         . S CNT=CNT+1
    95         . S RESULT=$P(BMI,U,2,99)
    96         . S RESULT=$$REPLACE^ORWGAPIX(RESULT,.REPLACE)
    97         . S $P(RESULT,U,2)=99999
    98         . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT)
    99         Q
    100         ;
    101 BMIDATA(DATA,ITEM,START,DFN,CNT,TMP)    ; from ORWGAPI4
    102         N DATE,DATE2,NODE,RESULT,VALUE,W K VALUE
    103         S DATE="",DATE2="",CNT=$G(CNT)
    104         F  S DATE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE)) Q:DATE=""  D
    105         . I DATE>START Q
    106         . S NODE=""
    107         . F  S NODE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE,NODE)) Q:NODE=""  D
    108         .. D VITAL^ORWGAPIA(.VALUE,NODE) S WT=$P($G(VALUE(7)),U) I 'WT Q
    109         .. S BMI=$$BMI(DFN,WT,DATE) I 'BMI Q
    110         .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_BMI
    111         .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT)
    112         Q
    113         ;
    114 BMI(DFN,WT,DATE)        ; $$(dfn,wt,date) -> bmi, else ""
    115         N HDATE,HT,NEXT,NODE,PREV
    116         I '$O(^PXRMINDX(120.5,"PI",DFN,8,0)) Q ""
    117         S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,DATE,""))
    118         I '$L(NODE) D
    119         . S NEXT=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE))
    120         . S PREV=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE),-1)
    121         . S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,$$CLOSEST(DATE,NEXT,PREV),""))
    122         I '$L(NODE) Q ""
    123         D VITAL^ORWGAPIA(.VALUE,NODE) S HT=$P($G(VALUE(7)),U) I 'HT Q ""
    124         Q $$CALCBMI(HT,WT)
    125         ;
    126 CALCBMI(HT,WT)  ; $$(ht,wt) -> bmi  uses (inches,lbs)
    127         S WT=WT/2.2 ;+$$WEIGHT^XLFMSMT(WT,"LB","KG")
    128         S HT=HT*2.54/100 ;+$$LENGTH^XLFMSMT(HT,"IN","M")
    129         Q $J(WT/(HT*HT),0,2)
    130         ;
    131 CLOSEST(DATE,NEXT,PREV) ;
    132         I $$FMDIFF^XLFDT(DATE,NEXT,2)>$$FMDIFF^XLFDT(DATE,PREV,2) Q PREV
    133         Q NEXT
    134         ;
    135 BMILAST(DFN,ARRAY,CNT)  ;
    136         N BMI,DATE,NUM,WT
    137         S (DATE,NUM,WT)=0
    138         F  S NUM=$O(ARRAY(NUM)) Q:NUM<1  D  Q:WT
    139         . I $P(ARRAY(NUM),U,2)'="WT" Q
    140         . S WT=+$P(ARRAY(NUM),U,3)
    141         . S DATE=$P(ARRAY(NUM),U,4)
    142         I 'WT Q
    143         I 'DATE Q
    144         S BMI=$$BMI(DFN,WT,DATE)
    145         I 'BMI Q
    146         S CNT=CNT+1
    147         S ARRAY(CNT)="-1^BMI^"_BMI_U_DATE_U_BMI_"^^"
    148         Q
    149         ;
    150 ZZ()    ; test use only - this code will be removed before v27 release
    151         N X,ZIP,ZZ
    152         S ZZ=$C(36)_$C(90)_$C(72)
    153         S ZIP="S X="_ZZ X ZIP
    154         Q X
     1ORWGAPIX ; SLC/STAFF - Graph External Calls ;9/29/06  11:49
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
     3 ;
     4DATE(X) ; $$(date/time) -> date/time
     5 N Y D ^%DT
     6 Q Y
     7ENDIQ1(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC
     8 N NUMDIC K RESULTS,^UTILITY("DIQ1",$J)
     9 Q:'$G(DIC)  Q:'$L(DR)  Q:'$G(DA)
     10 S NUMDIC=DIC
     11 D EN^DIQ1
     12 M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA)
     13 K ^UTILITY("DIQ1",$J)
     14 Q
     15EXT(Y,FILE,FIELD) ; $$(value,file,field) -> external value
     16 N C S C=$P($G(^DD(FILE,FIELD,0)),U,2) D Y^DIQ
     17 Q Y
     18EXTERNAL(FILE,FIELD,FLAG,VAL) ; $$(file,field,flag,internal value) -> external value
     19 Q $$EXTERNAL^DILFD(FILE,FIELD,FLAG,VAL)
     20EXTNAME(IEN,FN) ; $$(ien,file#) -> external form of pointer
     21 N REF
     22 S REF=$G(^DIC(FN,0,"GL"))
     23 I $L(REF),+IEN Q $P($G(@(REF_IEN_",0)")),U)
     24 Q ""
     25FILENM(FILENUM) ; $$(file#) -> file name
     26 N DIC,DO,NAME K DIC,DO
     27 S FILENUM=$$GBLREF(+$G(FILENUM))
     28 I '$L($G(FILENUM)) Q ""
     29 S DIC=FILENUM
     30 D DO^DIC1
     31 S NAME=$P(DO,U)
     32 Q NAME
     33GETDATA(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC
     34 N NUMDIC K RESULTS,^UTILITY("DIQ1",$J)
     35 Q:'$G(DIC)  Q:'$L(DR)  Q:'$G(DA)
     36 S NUMDIC=DIC
     37 D EN^DIQ1
     38 M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA)
     39 K ^UTILITY("DIQ1",$J)
     40 Q
     41GBLREF(FILENUM) ; $$(file#) -> global reference
     42 I '$G(FILENUM) Q ""
     43 Q $$ROOT^DILFD(+FILENUM)
     44INDEX(DIK,DA) ; index entry in file   -  from ORWGAPIP
     45 D IX1^DIK
     46 Q
     47XDEL(ENTITY,PARAM,NAME,ORERR) ; from ORWGAPIP
     48 D DEL^XPAR(ENTITY,PARAM,NAME,.ORERR)
     49 Q
     50XEN(ENTITY,PARAM,NAME,ORVAL,ORERR) ; from ORWGAPIP
     51 D EN^XPAR(ENTITY,PARAM,NAME,.ORVAL,.ORERR)
     52 Q
     53XENVAL(ORVALUES,PARAM) ;
     54 D ENVAL^XPAR(.ORVALUES,PARAM)
     55 Q
     56XGET(ENTITY,PARAM,INST,FORMAT) ; $$(...) -> parameter values
     57 Q $$GET^XPAR(ENTITY,PARAM,INST,FORMAT)
     58XGETLST(ORLIST,ENTITY,PARAM) ; from ORWGAPIP
     59 D GETLST^XPAR(.ORLIST,ENTITY,PARAM)
     60 Q
     61XGETLST1(ORLIST,ENTITY,PARAM,FORMAT,ORERR) ; from ORWGAPIP
     62 D GETLST^XPAR(.ORLIST,ENTITY,PARAM,FORMAT,.ORERR)
     63 Q
     64XGETWP(ORWP,ENTITY,PARAM,ALL) ; from ORWGAPIP
     65 D GETWP^XPAR(.ORWP,ENTITY,PARAM,ALL)
     66 Q
     67 ; kernel functions
     68FMADD(X,D,H,M,S) ;
     69 Q $$FMADD^XLFDT(X,$G(D),$G(H),$G(M),$G(S))
     70NOW() ;
     71 Q $$NOW^XLFDT
     72LOW(X) ;
     73 Q $$LOW^XLFSTR(X)
     74REPLACE(STRING,ORARRAY) ;
     75 Q $$REPLACE^XLFSTR(STRING,.ORARRAY)
     76TRIM(X,F,V) ;
     77 Q $$TRIM^XLFSTR(X,$G(F,"LR"),$G(V," "))
     78UP(X) ;
     79 Q $$UP^XLFSTR(X)
     80INSIG(NODE) ; $$(node) -> sig ; replace INSIG^ORWGAPIA with this code in v27
     81 N SIG,SUB,VALUES K VALUES
     82 S SUB=$P($G(NODE),";",2)
     83 D RXIN^ORWGAPIA(NODE,.VALUES)
     84 S SIG=""
     85 I SUB=5 D
     86 . S SIG="  Give: "_$G(VALUES("MR"))
     87 . S SIG=SIG_" "_$P($G(VALUES("SCH",1,0)),U)
     88 . S SIG=SIG_" "_$P($G(VALUES("SCH",1,0)),U,2)
     89 I SUB="IV" D
     90 . S SIG="  Give: "_$G(VALUES("DO"))
     91 . S SIG=SIG_" "_$$EXT^ORWGAPIX($G(VALUES("START")),55.01,.02)
     92 . S SIG=SIG_" "_$G(VALUES("SCH",1,0))
     93 Q SIG
     94 ;
     95BMIITEMS(ITEMS,CNT,TMP) ; from ORWGAPIR
     96 N BMI,NUM,REPLACE K REPLACE
     97 S REPLACE("WEIGHT")="BODY MASS INDEX"
     98 S BMI=""
     99 S NUM=0
     100 I 'TMP D
     101 . F  S NUM=$O(ITEMS(NUM)) Q:NUM<1  D
     102 .. I $P(ITEMS(NUM),U,2)=8 S $P(BMI,U)=1
     103 .. I $P(ITEMS(NUM),U,2)=9 S $P(BMI,U,2)=ITEMS(NUM)
     104 I TMP D
     105 . F  S NUM=$O(^TMP(ITEMS,$J,NUM)) Q:NUM<1  D
     106 .. I $P(^TMP(ITEMS,$J,NUM),U,2)=8 S $P(BMI,U)=1
     107 .. I $P(^TMP(ITEMS,$J,NUM),U,2)=9 S $P(BMI,U,2)=^TMP(ITEMS,$J,NUM)
     108 I BMI,$L(BMI)>3 D
     109 . S CNT=CNT+1
     110 . S RESULT=$P(BMI,U,2,99)
     111 . S RESULT=$$REPLACE^ORWGAPIX(RESULT,.REPLACE)
     112 . S $P(RESULT,U,2)=99999
     113 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT)
     114 Q
     115 ;
     116BMIDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPI4
     117 N DATE,DATE2,NODE,RESULT,VALUE,W K VALUE
     118 S DATE="",DATE2="",CNT=$G(CNT)
     119 F  S DATE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE)) Q:DATE=""  D
     120 . I DATE>START Q
     121 . S NODE=""
     122 . F  S NODE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE,NODE)) Q:NODE=""  D
     123 .. D VITAL^ORWGAPIA(.VALUE,NODE) S WT=$P($G(VALUE(7)),U) I 'WT Q
     124 .. S BMI=$$BMI(DFN,WT,DATE) I 'BMI Q
     125 .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_BMI
     126 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT)
     127 Q
     128 ;
     129BMI(DFN,WT,DATE) ; $$(dfn,wt,date) -> bmi, else ""
     130 N HDATE,HT,NEXT,NODE,PREV
     131 I '$O(^PXRMINDX(120.5,"PI",DFN,8,0)) Q ""
     132 S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,DATE,""))
     133 I '$L(NODE) D
     134 . S NEXT=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE))
     135 . S PREV=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE),-1)
     136 . S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,$$CLOSEST(DATE,NEXT,PREV),""))
     137 I '$L(NODE) Q ""
     138 D VITAL^ORWGAPIA(.VALUE,NODE) S HT=$P($G(VALUE(7)),U) I 'HT Q ""
     139 Q $$CALCBMI(HT,WT)
     140 ;
     141CALCBMI(HT,WT) ; $$(ht,wt) -> bmi  uses (inches,lbs)
     142 S WT=WT/2.2 ;+$$WEIGHT^XLFMSMT(WT,"LB","KG")
     143 S HT=HT*2.54/100 ;+$$LENGTH^XLFMSMT(HT,"IN","M")
     144 Q $J(WT/(HT*HT),0,2)
     145 ;
     146CLOSEST(DATE,NEXT,PREV) ;
     147 I $$FMDIFF^XLFDT(DATE,NEXT,2)>$$FMDIFF^XLFDT(DATE,PREV,2) Q PREV
     148 Q NEXT
     149 ;
     150BMILAST(DFN,ARRAY,CNT) ;
     151 N BMI,DATE,NUM,WT
     152 S (DATE,NUM,WT)=0
     153 F  S NUM=$O(ARRAY(NUM)) Q:NUM<1  D  Q:WT
     154 . I $P(ARRAY(NUM),U,2)'="WT" Q
     155 . S WT=+$P(ARRAY(NUM),U,3)
     156 . S DATE=$P(ARRAY(NUM),U,4)
     157 I 'WT Q
     158 I 'DATE Q
     159 S BMI=$$BMI(DFN,WT,DATE)
     160 I 'BMI Q
     161 S CNT=CNT+1
     162 S ARRAY(CNT)="-1^BMI^"_BMI_U_DATE_U_BMI_"^^"
     163 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGRPC.m

    r613 r623  
    1 ORWGRPC ; SLC/STAFF - Graph RPC ;3/9/06  13:59
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3         ;
    4 ALLITEMS(ITEMS,DFN)     ; RPC - get all items of data on patient (procedures, tests, codes,..)
    5         D ALLITEMS^ORWGAPI("ORWGRPC",DFN)
    6         S ITEMS=$NA(^TMP("ORWGRPC",$J))
    7         Q
    8         ;
    9 ALLVIEWS(DATA,VIEW,USER)        ; RPC - get all graph views
    10         D ALLVIEWS^ORWGAPI("ORWGRPC",+$G(VIEW),+$G(USER))
    11         S DATA=$NA(^TMP("ORWGRPC",$J))
    12         Q
    13         ;
    14 CLASS(DATA,TYPE)        ; RPC - get classifications
    15         D CLASS^ORWGAPI("ORWGRPC",TYPE)
    16         S DATA=$NA(^TMP("ORWGRPC",$J))
    17         Q
    18         ;
    19 DATEDATA(DATA,OLDEST,NEWEST,TYPEITEM,DFN)       ; RPC - get data for an item on patient in date range
    20         D DATEDATA^ORWGAPI("ORWGRPC",OLDEST,NEWEST,TYPEITEM,DFN)
    21         S DATA=$NA(^TMP("ORWGRPC",$J))
    22         Q
    23         ;
    24 DATEITEM(DATA,OLDEST,NEWEST,FNUM,DFN)   ; RPC - get patient items in date range for a type
    25         D DATEITEM^ORWGAPI("ORWGRPC",OLDEST,NEWEST,FNUM,DFN)
    26         S DATA=$NA(^TMP("ORWGRPC",$J))
    27         Q
    28         ;
    29 DELVIEWS(ERR,NAME,PUBLIC)       ; RPC - delete a graph view
    30         D DELVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC))
    31         S ERR=$NA(^TMP("ORWGRPC",$J))
    32         Q
    33         ;
    34 DETAIL(ITEMS,DFN,DATE1,DATE2,VAL,COMP)  ; RPC - get all reports for types of data from items and date range
    35         D DETAIL^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,.VAL,$G(COMP))
    36         S ITEMS=$NA(^TMP("ORWGRPC",$J))
    37         Q
    38         ;
    39 DETAILS(ITEMS,DFN,DATE1,DATE2,TYPE,COMP)        ; RPC - get report for type of data for a date or date range
    40         D DETAILS^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,TYPE,$G(COMP))
    41         S ITEMS=$NA(^TMP("ORWGRPC",$J))
    42         Q
    43         ;
    44 FASTDATA(DATA,DFN)      ; RPC - get all data (non-lab) set up on patient
    45         D FASTDATA^ORWGAPI(.DATA,DFN)
    46         Q
    47         ;
    48 FASTITEM(ITEMS,DFN)     ; RPC - get all items set up on patient
    49         D FASTITEM^ORWGAPI(.ITEMS,DFN)
    50         Q
    51         ;
    52 FASTLABS(DATA,DFN)      ; RPC - get all lab data set up on patient
    53         D FASTLABS^ORWGAPI(.DATA,DFN)
    54         Q
    55         ;
    56 FASTTASK(STATUS,DFN,OLDDFN)     ; set up all data and items on patient
    57         D FASTTASK^ORWGAPI(.STATUS,DFN,$G(OLDDFN))
    58         Q
    59         ;
    60 GETDATES(DATA,REPORTID) ; RPC - get graph date range
    61         D GETDATES^ORWGAPI("ORWGRPC",$G(REPORTID))
    62         S DATA=$NA(^TMP("ORWGRPC",$J))
    63         Q
    64         ;
    65 GETPREF(DATA)   ; RPC - get graph settings
    66         D GETPREF^ORWGAPI("ORWGRPC")
    67         S DATA=$NA(^TMP("ORWGRPC",$J))
    68         Q
    69         ;
    70 GETSIZE(DATA)   ; RPC - get graph positions and sizes
    71         D GETSIZE^ORWGAPI("ORWGRPC")
    72         S DATA=$NA(^TMP("ORWGRPC",$J))
    73         Q
    74         ;
    75 GETVIEWS(DATA,ALL,PUBLIC,EXT,USER)      ; RPC - get graph views
    76         D GETVIEWS^ORWGAPI("ORWGRPC",ALL,+$G(PUBLIC),+$G(EXT),+$G(USER))
    77         S DATA=$NA(^TMP("ORWGRPC",$J))
    78         Q
    79         ;
    80 ITEMDATA(DATA,ITEM,START,DFN)   ; RPC - get data of an item on patient (glucose results)
    81         D ITEMDATA^ORWGAPI("ORWGRPC",ITEM,START,DFN)
    82         S DATA=$NA(^TMP("ORWGRPC",$J))
    83         Q
    84         ;
    85 ITEMS(ITEMS,DFN,TYPE)   ; RPC - get items of a type of data on patient (lab tests)
    86         D ITEMS^ORWGAPI("ORWGRPC",DFN,TYPE)
    87         S ITEMS=$NA(^TMP("ORWGRPC",$J))
    88         Q
    89         ;
    90 LOOKUP(VAL,INFO,FROM,DIR)       ; RPC - get item names for long lookup
    91         D LOOKUP^ORWGAPI(.VAL,INFO,.FROM,DIR)
    92         Q
    93         ;
    94 PUBLIC(VAL)     ; RPC - check if user can edit public views and settings
    95         S VAL=$$PUBLIC^ORWGAPI(DUZ)
    96         Q
    97         ;
    98 RPTPARAM(VAL,IEN)       ; RPC - return PARAM1^PARAM2 for graph report
    99         S VAL=$$RPTPARAM^ORWGAPI(IEN)
    100         Q
    101         ;
    102 SETPREF(ERR,SETTING,PUBLIC)     ; RPC - set a graph setting
    103         D SETPREF^ORWGAPI("ORWGRPC",SETTING,+$G(PUBLIC))
    104         S ERR=$NA(^TMP("ORWGRPC",$J))
    105         Q
    106         ;
    107 SETSIZE(ERR,VAL)        ; RPC - set graph positions and sizes
    108         D SETSIZE^ORWGAPI("ORWGRPC",.VAL)
    109         S ERR=$NA(^TMP("ORWGRPC",$J))
    110         Q
    111         ;
    112 SETVIEWS(ERR,NAME,PUBLIC,VAL)   ; RPC - set a graph view
    113         D SETVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC),.VAL)
    114         S ERR=$NA(^TMP("ORWGRPC",$J))
    115         Q
    116         ;
    117 TAX(DATA,ALL,REMTAX)    ; RPC - get reminder taxonomies
    118         D TAX^ORWGAPI("ORWGRPC",+$G(ALL),.REMTAX)
    119         S DATA=$NA(^TMP("ORWGRPC",$J))
    120         Q
    121         ;
    122 TESTING(DATA)   ; RPC - cache data
    123         D TESTING^ORWGAPI("ORWGRPC")
    124         S DATA=$NA(^TMP("ORWGRPC",$J))
    125         Q
    126         ;
    127 TESTSPEC(DATA)  ; RPC - get test/spec info on all lab tests
    128         D TESTSPEC^ORWGAPI("ORWGRPC")
    129         S DATA=$NA(^TMP("ORWGRPC",$J))
    130         Q
    131         ;
    132 TYPES(TYPES,DFN,SUB)    ; RPC - get all the types of data on a patient (SUB=1, gets subtypes, DFN=0 gets all types),
    133         D TYPES^ORWGAPI("ORWGRPC",DFN,+$G(SUB))
    134         S TYPES=$NA(^TMP("ORWGRPC",$J))
    135         Q
    136         ;
     1ORWGRPC ; SLC/STAFF - Graph RPC ;3/9/06  13:59
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3 ;
     4ALLITEMS(ITEMS,DFN) ; RPC - get all items of data on patient (procedures, tests, codes,..)
     5 D ALLITEMS^ORWGAPI("ORWGRPC",DFN)
     6 S ITEMS=$NA(^TMP("ORWGRPC",$J))
     7 Q
     8 ;
     9CLASS(DATA,TYPE) ; RPC - get classifications
     10 D CLASS^ORWGAPI("ORWGRPC",TYPE)
     11 S DATA=$NA(^TMP("ORWGRPC",$J))
     12 Q
     13 ;
     14DATEITEM(DATA,OLDEST,NEWEST,FNUM,DFN) ; RPC - get patient items in date range for a type
     15 D DATEITEM^ORWGAPI("ORWGRPC",OLDEST,NEWEST,FNUM,DFN)
     16 S DATA=$NA(^TMP("ORWGRPC",$J))
     17 Q
     18 ;
     19DELVIEWS(ERR,NAME,PUBLIC) ; RPC - delete a graph view
     20 D DELVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC))
     21 S ERR=$NA(^TMP("ORWGRPC",$J))
     22 Q
     23 ;
     24DETAIL(ITEMS,DFN,DATE1,DATE2,VAL,COMP) ; RPC - get all reports for types of data from items and date range
     25 D DETAIL^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,.VAL,$G(COMP))
     26 S ITEMS=$NA(^TMP("ORWGRPC",$J))
     27 Q
     28 ;
     29DETAILS(ITEMS,DFN,DATE1,DATE2,TYPE,COMP) ; RPC - get report for type of data for a date or date range
     30 D DETAILS^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,TYPE,$G(COMP))
     31 S ITEMS=$NA(^TMP("ORWGRPC",$J))
     32 Q
     33 ;
     34GETDATES(DATA,REPORTID) ; RPC - get graph date range
     35 D GETDATES^ORWGAPI("ORWGRPC",$G(REPORTID))
     36 S DATA=$NA(^TMP("ORWGRPC",$J))
     37 Q
     38 ;
     39GETPREF(DATA) ; RPC - get graph settings
     40 D GETPREF^ORWGAPI("ORWGRPC")
     41 S DATA=$NA(^TMP("ORWGRPC",$J))
     42 Q
     43 ;
     44GETSIZE(DATA) ; RPC - get graph positions and sizes
     45 D GETSIZE^ORWGAPI("ORWGRPC")
     46 S DATA=$NA(^TMP("ORWGRPC",$J))
     47 Q
     48 ;
     49GETVIEWS(DATA,ALL,PUBLIC,EXT) ; RPC - get graph views
     50 D GETVIEWS^ORWGAPI("ORWGRPC",ALL,+$G(PUBLIC),+$G(EXT))
     51 S DATA=$NA(^TMP("ORWGRPC",$J))
     52 Q
     53 ;
     54ITEMDATA(DATA,ITEM,START,DFN) ; RPC - get data of an item on patient (glucose results)
     55 S ITEM=$$UP^ORWGAPIX(ITEM)
     56 D ITEMDATA^ORWGAPI("ORWGRPC",ITEM,START,DFN)
     57 S DATA=$NA(^TMP("ORWGRPC",$J))
     58 Q
     59 ;
     60ITEMS(ITEMS,DFN,TYPE) ; RPC - get items of a type of data on patient (lab tests)
     61 D ITEMS^ORWGAPI("ORWGRPC",DFN,TYPE)
     62 S ITEMS=$NA(^TMP("ORWGRPC",$J))
     63 Q
     64 ;
     65LOOKUP(VAL,INFO,FROM,DIR) ; RPC - get item names for long lookup
     66 D LOOKUP^ORWGAPI(.VAL,INFO,.FROM,DIR)
     67 Q
     68 ;
     69PUBLIC(VAL) ; RPC - check if user can edit public views and settings
     70 S VAL=$$PUBLIC^ORWGAPI(DUZ)
     71 Q
     72 ;
     73RPTPARAM(VAL,IEN) ; RPC - return PARAM1^PARAM2 for graph report
     74 S VAL=$$RPTPARAM^ORWGAPI(IEN)
     75 Q
     76 ;
     77SETPREF(ERR,SETTING,PUBLIC) ; RPC - set a graph setting
     78 D SETPREF^ORWGAPI("ORWGRPC",SETTING,+$G(PUBLIC))
     79 S ERR=$NA(^TMP("ORWGRPC",$J))
     80 Q
     81 ;
     82SETSIZE(ERR,VAL) ; RPC - set graph positions and sizes
     83 D SETSIZE^ORWGAPI("ORWGRPC",.VAL)
     84 S ERR=$NA(^TMP("ORWGRPC",$J))
     85 Q
     86 ;
     87SETVIEWS(ERR,NAME,PUBLIC,VAL) ; RPC - set a graph view
     88 D SETVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC),.VAL)
     89 S ERR=$NA(^TMP("ORWGRPC",$J))
     90 Q
     91 ;
     92TAX(DATA,ALL,REMTAX) ; RPC - get reminder taxonomies
     93 D TAX^ORWGAPI("ORWGRPC",+$G(ALL),.REMTAX)
     94 S DATA=$NA(^TMP("ORWGRPC",$J))
     95 Q
     96 ;
     97TESTSPEC(DATA) ; RPC - get test/spec info on all lab tests
     98 D TESTSPEC^ORWGAPI("ORWGRPC")
     99 S DATA=$NA(^TMP("ORWGRPC",$J))
     100 Q
     101 ;
     102TYPES(TYPES,DFN,SUB) ; RPC - get all the types of data on a patient (SUB=1, gets subtypes, DFN=0 gets all types),
     103 D TYPES^ORWGAPI("ORWGRPC",DFN,+$G(SUB))
     104 S TYPES=$NA(^TMP("ORWGRPC",$J))
     105 Q
     106 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWNSS.m

    r613 r623  
    1 ORWNSS  ;JDL/SLC Non-Standard Schedule ;11/24/06
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,243**;Dec 17, 1997;Build 242
    3 NSSOK(ORY,ORX)  ;Check availability for Non-standard schedule
    4         N VAL
    5         S VAL=$$PATCH^XPDUTL("PSJ*5.0*113")
    6         S ORY=VAL
    7         Q
    8 NSSMSG(ORY)     ;Retrieve site message for None-Standard Schedule
    9         N ORSRV
    10         S ORY=""
    11         S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
    12         S ORY=$$GET^XPAR("SRV.`"_+$G(ORSRV)_"^DIV^SYS","ORWIM NSS MESSAGE",1,"I")
    13         Q
    14 VALSCH(ORY,ORID)        ;Validate a schedule for IM order; 1: valid, 0: invalid
    15         ;
    16         S ORY=0
    17         Q:'$D(^OR(100,+ORID,0))
    18         N IPGRP,ORGRP
    19         S IPGRP=$O(^ORD(100.98,"B","UD RX",0))
    20         S ORGRP=$P($G(^OR(100,+ORID,0)),U,11)
    21         I ORGRP'=IPGRP S ORY=1 Q
    22         N SCH,IDX,SCHVAL S (SCH,SCHVAL)=""
    23         I $D(^OR(100,+ORID,4.5,"ID","SCHEDULE")) S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
    24         I SCH="" S ORY=1 Q
    25         S IDX=0 F  S IDX=$O(^OR(100,+ORID,4.5,SCH,IDX)) Q:'IDX  D
    26         . S SCHVAL=$G(^OR(100,+ORID,4.5,SCH,IDX))
    27         . Q:'$L(SCHVAL)
    28         . D VALSCH^ORWDPS33(.ORY,SCHVAL,"I")
    29         . I ORY=0 Q
    30         Q
    31 QOSCH(ORY,QOID) ;Validate IM QO schedule
    32         ;QOID: Inpt Pharmacy QO
    33         S ORY=""
    34         N QOSCH,SCHID,SCHVAL,RST
    35         S SCHID=$O(^ORD(101.41,"B","OR GTX SCHEDULE",0))
    36         S (QOSCH,SCHVAL)="",RST=1
    37         I '$D(^ORD(101.41,+QOID,6,"D",SCHID)) S ORY="schedule is not defined." Q
    38         S QOSCH=$O(^ORD(101.41,+QOID,6,"D",SCHID,0))
    39         I 'QOSCH S ORY="schedule is not defined." Q
    40         N IDX S IDX=0
    41         F  S IDX=$O(^ORD(101.41,+QOID,6,QOSCH,IDX)) Q:'IDX!('RST)  D
    42         . S SCHVAL=^ORD(101.41,+QOID,6,QOSCH,IDX)
    43         . I $$UP^XLFSTR(SCHVAL)="OTHER" S ORY="OTHER" Q
    44         . D VALSCH^ORWDPS33(.RST,SCHVAL,"I")
    45         . I RST=0 S ORY="This quick order contains a non-standard administration schedule." Q
    46         Q
    47 CHKSCH(ORY,SCH) ;Validate schedule
    48         Q:SCH=""
    49         D VALSCH^ORWDPS33(.ORY,SCH,"I")
    50         Q
     1ORWNSS ;JDL/SLC Non-Standard Schedule ;12/9/04  12:02
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195**;Dec 17, 1997
     3NSSOK(ORY,ORX) ;Check availability for Non-standard schedule
     4 N VAL
     5 S VAL=$$PATCH^XPDUTL("PSJ*5.0*113")
     6 S ORY=VAL
     7 Q
     8NSSMSG(ORY) ;Retrieve site message for None-Standard Schedule
     9 N ORSRV
     10 S ORY=""
     11 S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
     12 S ORY=$$GET^XPAR("SRV.`"_+$G(ORSRV)_"^DIV^SYS","ORWIM NSS MESSAGE",1,"I")
     13 Q
     14VALSCH(ORY,ORID) ;Validate a schedule for IM order; 1: valid, 0: invalid
     15 ;
     16 S ORY=0
     17 Q:'$D(^OR(100,+ORID,0))
     18 N IPGRP,ORGRP
     19 S IPGRP=$O(^ORD(100.98,"B","UD RX",0))
     20 S ORGRP=$P($G(^OR(100,+ORID,0)),U,11)
     21 I ORGRP'=IPGRP S ORY=1 Q
     22 N SCH,IDX,SCHVAL S (SCH,SCHVAL)=""
     23 I $D(^OR(100,+ORID,4.5,"ID","SCHEDULE")) S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
     24 I SCH="" S ORY=1 Q
     25 S IDX=0 F  S IDX=$O(^OR(100,+ORID,4.5,SCH,IDX)) Q:'IDX  D
     26 . S SCHVAL=$G(^OR(100,+ORID,4.5,SCH,IDX))
     27 . Q:'$L(SCHVAL)
     28 . D VALSCH^ORWDPS32(.ORY,SCHVAL,"I")
     29 . I ORY=0 Q
     30 Q
     31QOSCH(ORY,QOID) ;Validate IM QO schedule
     32 ;QOID: Inpt Pharmacy QO
     33 S ORY=""
     34 N QOSCH,SCHID,SCHVAL,RST
     35 S SCHID=$O(^ORD(101.41,"B","OR GTX SCHEDULE",0))
     36 S (QOSCH,SCHVAL)="",RST=1
     37 I '$D(^ORD(101.41,+QOID,6,"D",SCHID)) S ORY="schedule is not defined." Q
     38 S QOSCH=$O(^ORD(101.41,+QOID,6,"D",SCHID,0))
     39 I 'QOSCH S ORY="schedule is not defined." Q
     40 N IDX S IDX=0
     41 F  S IDX=$O(^ORD(101.41,+QOID,6,QOSCH,IDX)) Q:'IDX!('RST)  D
     42 . S SCHVAL=^ORD(101.41,+QOID,6,QOSCH,IDX)
     43 . I $$UP^XLFSTR(SCHVAL)="OTHER" S ORY="OTHER" Q
     44 . D VALSCH^ORWDPS32(.RST,SCHVAL,"I")
     45 . I RST=0 S ORY="This quick order contains a non-standard administration schedule." Q
     46 Q
     47CHKSCH(ORY,SCH) ;Validate schedule
     48 Q:SCH=""
     49 D VALSCH^ORWDPS32(.ORY,SCH,"I")
     50 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWOR.m

    r613 r623  
    1 ORWOR   ; SLC/KCM - Orders Calls;10:54 PM  08/15/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,141,163,187,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 CURRENT(LST,DFN)        ; Get Current Orders for a Patient
    5         ; Returns two lists in ^TMP("ORW",$J), fields and text
    6         N TM,IEN,X,X0,X3,CTR,IDX,I
    7         K ^TMP("ORW",$J)
    8         S IDX=0,DFN=DFN_";DPT("
    9         S TM=0 F  S TM=$O(^OR(100,"AC",DFN,TM)) Q:TM<1  D
    10         . S IEN=0 F  S IEN=$O(^OR(100,"AC",DFN,TM,IEN)) Q:IEN<1  D
    11         . . S X0=^OR(100,IEN,0),X3=^(3)
    12         . . S X=IEN_U_$P(X0,U,7)_U_$P(X0,U,11)_U_$P(X3,U,6)_U_$P(X3,U,3)
    13         . . S ^TMP("ORW",$J,IDX+1)=X
    14         . . S (CTR,I)=0,X=""
    15         . . F  S I=$O(^OR(100,IEN,1,I)) Q:I<1  D  Q:CTR>244
    16         . . . S X=X_$E(^OR(100,IEN,1,I,0),1,(245-CTR)),CTR=$L(X)
    17         . . S ^TMP("ORW",$J,IDX+2)=X,IDX=IDX+2
    18         ; S LST=$NA(^TMP("ORW",$J))
    19         M LST=^TMP("ORW",$J)
    20         Q
    21 DETAIL(LST,ORID,DFN)       ; Return details of ORID (shell to kill VIDEO subs)
    22         Q:'+ORID
    23         I $G(DFN) N ORVP S ORVP=DFN_";DPT("
    24         S LST="^TMP(""ORTXT"",$J)"
    25         D DETAIL^ORQ2(.LST,ORID)
    26         K @LST@("VIDEO")
    27         S LST=$NA(^TMP("ORTXT",$J)),@LST=""
    28         Q
    29 RESULT(REF,DFN,ORID,ID)      ; Return results of order identified by ID
    30         K ^TMP("ORXPND",$J)
    31         N ORESULTS,ORVP,LCNT S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT("
    32         D ORDERS^ORCXPND1
    33         K ^TMP("ORXPND",$J,"VIDEO")
    34         S REF=$NA(^TMP("ORXPND",$J))
    35         Q
    36 RESHIST(REF,DFN,ORID,ID)             ; Return result history of associated tests identified by ID
    37         K ^TMP("ORXPND",$J)
    38         N ORESULTS,ORVP,LCNT
    39         S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT("
    40         D ORDHIST^ORWOR2
    41         K ^TMP("ORXPND",$J,"VIDEO")
    42         S REF=$NA(^TMP("ORXPND",$J))
    43         Q
    44 TSALL(LST)           ; Return list of treating specialties
    45         N Y S Y=0
    46         F  S Y=$O(^DIC(45.7,Y)) Q:'Y  I $$ACTIVE^DGACT(45.7,Y) S LST(Y)=Y_U_$P(^DIC(45.7,Y,0),U)
    47         Q
    48 DT(X)   ; -- Returns FM date for X (SEE ORCHTAB1)
    49         N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
    50         Q +Y
    51 VWSET(ORERR,VIEW)             ; Set the preferred view for orders
    52         ; VIEW:  semi-colon delimited record
    53         ;        1 - Relative From Date/Time or ""
    54         ;        2 - Relative Thru Date/Time or ""
    55         ;        3 - Filter
    56         ;        4 - Display Group Pointer
    57         ;        5 - Format (preserve for list manager)
    58         ;        6 - chronological display (R or F)
    59         ;        7 - sort by display group
    60         N FMT
    61         ; use short name for display group instead of pointer
    62         I $E($P(VIEW,";",2))="T" S $P(VIEW,";",2)=$P($P(VIEW,";",2),"@") ;allows all orders for Today
    63         S $P(VIEW,";",4)=$P($G(^ORD(100.98,+$P(VIEW,";",4),0)),U,3)
    64         ; use last saved format, since this is used only by LM
    65         S FMT=$P($$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),";",5)
    66         S:'$L(FMT) FMT="L" S $P(VIEW,";",5)=FMT
    67         ; and save the parameter
    68         D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT ORDERS",1,VIEW,.ORERR)
    69         Q
    70 VWGET(REC)           ; Get the preferred view for orders
    71         N FROM,THRU,FILTER,DGRP,FRMT,CHRN,BYGRP,S,VNAME,FL
    72         S REC=$$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),S=";"
    73         S FROM=$$DT($P(REC,S)),THRU=$$DT($P(REC,S,2)),FILTER=$P(REC,S,3)
    74         S DGRP=$P(REC,S,4),FRMT=$P(REC,S,5),CHRN=$P(REC,S,6),BYGRP=$P(REC,S,7)
    75         S:'$L(DGRP) DGRP="ALL" S DGRP=+$O(^ORD(100.98,"B",DGRP,0))
    76         I FILTER="" S FILTER=2  ; active orders
    77         I CHRN="" S CHRN="R"    ; reverse chronological
    78         I BYGRP="" S BYGRP=1    ; sort by display group
    79         ; set up view name
    80         D REVSTS^ORWORDG(.FL)
    81         S I=0 F  S I=$O(FL(I)) Q:'I  Q:+FL(I)=FILTER
    82         S VNAME=$P($G(FL(+I)),U,2)
    83         I '("^6^8^9^10^19^20^"[(U_FILTER_U)) S VNAME=VNAME_" Orders"
    84         I FILTER=2 S VNAME="Active Orders (includes Pending & Recent Activity)"
    85         I FILTER=23 S VNAME="Current Orders (Active & Pending Status Only)"
    86         S VNAME=VNAME_" - "_$P($G(^ORD(100.98,DGRP,0)),U)
    87         I (FROM>0)!(THRU>0) D
    88         . S VNAME=VNAME_" ("_$$FMTE^XLFDT(FROM,"2D")_" thru "
    89         . S VNAME=VNAME_$S(THRU>0:$$FMTE^XLFDT(THRU,"2D"),1:"")_")"
    90         S REC=FROM_S_THRU_S_FILTER_S_DGRP_S_FRMT_S_CHRN_S_BYGRP_S_VNAME
    91         Q
    92 SHEETS(LST,ORVP)        ; Return Order Sheets for a patient
    93         N ELST,ETYP,ORIFN,TS,I
    94         S ORVP=ORVP_";DPT("
    95         S ETYP="" F  S ETYP=$O(^OR(100,"AEVNT",ORVP,ETYP)) Q:ETYP=""  D
    96         . S ORIFN=0 F  S ORIFN=$O(^OR(100,"AEVNT",ORVP,ETYP,ORIFN)) Q:'ORIFN  D
    97         . . I (ETYP="A")!(ETYP="T") S ELST(ETYP,$P($G(^OR(100,+ORIFN,0)),U,13))=""
    98         S LST(1)="C;O^Current View",I=1
    99         S TS="" F  S TS=$O(ELST("A",TS)) Q:TS=""  D
    100         . S I=I+1,LST(I)="A;"_TS_U_"Admit to "_$P($G(^DIC(45.7,TS,0)),U)
    101         S I=I+1,LST(I)="A;-1^Admit..."
    102         S TS="" F  S TS=$O(ELST("T",TS)) Q:TS=""  D
    103         . S I=I+1,LST(I)="T;"_TS_U_"Transfer to "_$P($G(^DIC(45.7,TS,0)),U)
    104         I $L($G(^DPT(+ORVP,.1))) D
    105         . S I=I+1,LST(I)="T;-1^Transfer..."
    106         . S I=I+1,LST(I)="D;0^Discharge"
    107         Q
    108 EVENTS(LST,EVT) ; Return general delayed events categories for a patient
    109         N EVTI
    110         S EVTI=0
    111         S EVTI=EVTI+1,LST(EVTI)="A;-1^Admit..."
    112         S EVTI=EVTI+1,LST(EVTI)="T;-1^Transfer..."
    113         S EVTI=EVTI+1,LST(EVTI)="D;0^Discharge"
    114         Q
    115 UNSIGN(LST,ORVP,HAVE)     ; Return Unsigned Orders that are not on client
    116         N IFN,ACT,X8,ENT,LVL,TM,ILST S ILST=0
    117         Q:'$D(^XUSEC("ORES",DUZ))
    118         S ORVP=ORVP_";DPT("
    119         S ENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"")
    120         S LVL=$$GET^XPAR(ENT,"OR UNSIGNED ORDERS ON EXIT")
    121         Q:'LVL
    122         S TM=0 F  S TM=$O(^OR(100,"AS",ORVP,TM)) Q:TM<1  D
    123         . S IFN=0 F  S IFN=$O(^OR(100,"AS",ORVP,TM,IFN)) Q:IFN<1  D
    124         . . S ACT=0 F  S ACT=$O(^OR(100,"AS",ORVP,TM,IFN,ACT)) Q:ACT<1  D
    125         . . . Q:$D(HAVE(IFN_";"_ACT))                        ;in Changes
    126         . . . S X8=$G(^OR(100,IFN,8,ACT,0))
    127         . . . I '$S(LVL=1&($P(X8,U,3)=DUZ):1,LVL=2:1,1:0) Q  ;chk user
    128         . . . S ILST=ILST+1,LST(ILST)=IFN_";"_ACT_U_$P(X8,U,3)
    129         Q
    130 PKIUSE(RETURN)  ; RPC determines user can use PKI Digital Signature
    131         S RETURN=0
    132         I $$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q") S RETURN=1
    133         Q
    134 PKISITE(RETURN) ; RPC determines if PKI is turned on at the site
    135         S RETURN=0
    136         Q:'$L($T(STORESIG^XUSSPKI))  ;Check for Kernel piece
    137         Q:'$L($T(DOSE^PSSOPKI1))  ;Check for Pharmacy piece
    138         I $$GET^XPAR("ALL","ORWOR PKI SITE",1,"Q") S RETURN=1
    139         Q
    140 ACTXT(ORY,ORIFN)        ;Return detail action information
    141         N ORI,CNT,OR0,OR3,OR6
    142         K ^TMP("ORACTXT",$J)
    143         S ORY="^TMP(""ORACTXT"",$J)",ORI=$P(ORIFN,";",2)
    144         S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6))
    145         F  S ORI=$O(^OR(100,+ORIFN,8,ORI)) Q:ORI'>0  S ACTION=$G(^(ORI,0)) D ACT^ORQ20
    146         S ORY=$NA(^TMP("ORACTXT",$J)),@ORY=""
    147         Q
    148 EXPIRED(ORY)    ;return FM date/time to begin search for expired orders
    149         N HRS
    150         S HRS=$$GET^XPAR("ALL","ORWOR EXPIRED ORDERS",1,"I")
    151         S ORY=$$FMADD^XLFDT($$NOW^XLFDT,"","-"_HRS,"","")
    152         Q
     1ORWOR ; SLC/KCM - Orders Calls;10:54 PM  02 Feb 2003
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,141,163,187,190,215**;Dec 17, 1997
     3 ;
     4CURRENT(LST,DFN) ; Get Current Orders for a Patient
     5 ; Returns two lists in ^TMP("ORW",$J), fields and text
     6 N TM,IEN,X,X0,X3,CTR,IDX,I
     7 K ^TMP("ORW",$J)
     8 S IDX=0,DFN=DFN_";DPT("
     9 S TM=0 F  S TM=$O(^OR(100,"AC",DFN,TM)) Q:TM<1  D
     10 . S IEN=0 F  S IEN=$O(^OR(100,"AC",DFN,TM,IEN)) Q:IEN<1  D
     11 . . S X0=^OR(100,IEN,0),X3=^(3)
     12 . . S X=IEN_U_$P(X0,U,7)_U_$P(X0,U,11)_U_$P(X3,U,6)_U_$P(X3,U,3)
     13 . . S ^TMP("ORW",$J,IDX+1)=X
     14 . . S (CTR,I)=0,X=""
     15 . . F  S I=$O(^OR(100,IEN,1,I)) Q:I<1  D  Q:CTR>244
     16 . . . S X=X_$E(^OR(100,IEN,1,I,0),1,(245-CTR)),CTR=$L(X)
     17 . . S ^TMP("ORW",$J,IDX+2)=X,IDX=IDX+2
     18 ; S LST=$NA(^TMP("ORW",$J))
     19 M LST=^TMP("ORW",$J)
     20 Q
     21DETAIL(LST,ORID,DFN)    ; Return details of ORID (shell to kill VIDEO subs)
     22 Q:'+ORID
     23 I $G(DFN) N ORVP S ORVP=DFN_";DPT("
     24 S LST="^TMP(""ORTXT"",$J)"
     25 D DETAIL^ORQ2(.LST,ORID)
     26 K @LST@("VIDEO")
     27 S LST=$NA(^TMP("ORTXT",$J)),@LST=""
     28 Q
     29RESULT(REF,DFN,ORID,ID)      ; Return results of order identified by ID
     30 K ^TMP("ORXPND",$J)
     31 N ORESULTS,ORVP,LCNT S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT("
     32 D ORDERS^ORCXPND1
     33 K ^TMP("ORXPND",$J,"VIDEO")
     34 S REF=$NA(^TMP("ORXPND",$J))
     35 Q
     36RESHIST(REF,DFN,ORID,ID)      ; Return result history of associated tests identified by ID
     37 K ^TMP("ORXPND",$J)
     38 N ORESULTS,ORVP,LCNT
     39 S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT("
     40 D ORDHIST^ORWOR2
     41 K ^TMP("ORXPND",$J,"VIDEO")
     42 S REF=$NA(^TMP("ORXPND",$J))
     43 Q
     44TSALL(LST)      ; Return list of treating specialties
     45 N Y S Y=0
     46 F  S Y=$O(^DIC(45.7,Y)) Q:'Y  I $$ACTIVE^DGACT(45.7,Y) S LST(Y)=Y_U_$P(^DIC(45.7,Y,0),U)
     47 Q
     48DT(X) ; -- Returns FM date for X (SEE ORCHTAB1)
     49 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
     50 Q +Y
     51VWSET(ORERR,VIEW)       ; Set the preferred view for orders
     52 ; VIEW:  semi-colon delimited record
     53 ;        1 - Relative From Date/Time or ""
     54 ;        2 - Relative Thru Date/Time or ""
     55 ;        3 - Filter
     56 ;        4 - Display Group Pointer
     57 ;        5 - Format (preserve for list manager)
     58 ;        6 - chronological display (R or F)
     59 ;        7 - sort by display group
     60 N FMT
     61 ; use short name for display group instead of pointer
     62 I $E($P(VIEW,";",2))="T" S $P(VIEW,";",2)=$P($P(VIEW,";",2),"@") ;allows all orders for Today
     63 S $P(VIEW,";",4)=$P($G(^ORD(100.98,+$P(VIEW,";",4),0)),U,3)
     64 ; use last saved format, since this is used only by LM
     65 S FMT=$P($$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),";",5)
     66 S:'$L(FMT) FMT="L" S $P(VIEW,";",5)=FMT
     67 ; and save the parameter
     68 D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT ORDERS",1,VIEW,.ORERR)
     69 Q
     70VWGET(REC)      ; Get the preferred view for orders
     71 N FROM,THRU,FILTER,DGRP,FRMT,CHRN,BYGRP,S,VNAME,FL
     72 S REC=$$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),S=";"
     73 S FROM=$$DT($P(REC,S)),THRU=$$DT($P(REC,S,2)),FILTER=$P(REC,S,3)
     74 S DGRP=$P(REC,S,4),FRMT=$P(REC,S,5),CHRN=$P(REC,S,6),BYGRP=$P(REC,S,7)
     75 S:'$L(DGRP) DGRP="ALL" S DGRP=+$O(^ORD(100.98,"B",DGRP,0))
     76 I FILTER="" S FILTER=2  ; active orders
     77 I CHRN="" S CHRN="R"    ; reverse chronological
     78 I BYGRP="" S BYGRP=1    ; sort by display group
     79 ; set up view name
     80 D REVSTS^ORWORDG(.FL)
     81 S I=0 F  S I=$O(FL(I)) Q:'I  Q:+FL(I)=FILTER
     82 S VNAME=$P($G(FL(+I)),U,2)
     83 I '("^6^8^9^10^19^20^"[(U_FILTER_U)) S VNAME=VNAME_" Orders"
     84 I FILTER=2 S VNAME="Active Orders (includes Pending & Recent Activity)"
     85 I FILTER=23 S VNAME="Current Orders (Active & Pending Status Only)"
     86 S VNAME=VNAME_" - "_$P($G(^ORD(100.98,DGRP,0)),U)
     87 I (FROM>0)!(THRU>0) D
     88 . S VNAME=VNAME_" ("_$$FMTE^XLFDT(FROM,"2D")_" thru "
     89 . S VNAME=VNAME_$S(THRU>0:$$FMTE^XLFDT(THRU,"2D"),1:"")_")"
     90 S REC=FROM_S_THRU_S_FILTER_S_DGRP_S_FRMT_S_CHRN_S_BYGRP_S_VNAME
     91 Q
     92SHEETS(LST,ORVP) ; Return Order Sheets for a patient
     93 N ELST,ETYP,ORIFN,TS,I
     94 S ORVP=ORVP_";DPT("
     95 S ETYP="" F  S ETYP=$O(^OR(100,"AEVNT",ORVP,ETYP)) Q:ETYP=""  D
     96 . S ORIFN=0 F  S ORIFN=$O(^OR(100,"AEVNT",ORVP,ETYP,ORIFN)) Q:'ORIFN  D
     97 . . I (ETYP="A")!(ETYP="T") S ELST(ETYP,$P($G(^OR(100,+ORIFN,0)),U,13))=""
     98 S LST(1)="C;O^Current View",I=1
     99 S TS="" F  S TS=$O(ELST("A",TS)) Q:TS=""  D
     100 . S I=I+1,LST(I)="A;"_TS_U_"Admit to "_$P($G(^DIC(45.7,TS,0)),U)
     101 S I=I+1,LST(I)="A;-1^Admit..."
     102 S TS="" F  S TS=$O(ELST("T",TS)) Q:TS=""  D
     103 . S I=I+1,LST(I)="T;"_TS_U_"Transfer to "_$P($G(^DIC(45.7,TS,0)),U)
     104 I $L($G(^DPT(+ORVP,.1))) D
     105 . S I=I+1,LST(I)="T;-1^Transfer..."
     106 . S I=I+1,LST(I)="D;0^Discharge"
     107 Q
     108EVENTS(LST,EVT) ; Return general delayed events categories for a patient
     109 N EVTI
     110 S EVTI=0
     111 S EVTI=EVTI+1,LST(EVTI)="A;-1^Admit..."
     112 S EVTI=EVTI+1,LST(EVTI)="T;-1^Transfer..."
     113 S EVTI=EVTI+1,LST(EVTI)="D;0^Discharge"
     114 Q
     115UNSIGN(LST,ORVP,HAVE)   ; Return Unsigned Orders that are not on client
     116 N IFN,ACT,X8,ENT,LVL,TM,ILST S ILST=0
     117 Q:'$D(^XUSEC("ORES",DUZ))
     118 S ORVP=ORVP_";DPT("
     119 S ENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"")
     120 S LVL=$$GET^XPAR(ENT,"OR UNSIGNED ORDERS ON EXIT")
     121 Q:'LVL
     122 S TM=0 F  S TM=$O(^OR(100,"AS",ORVP,TM)) Q:TM<1  D
     123 . S IFN=0 F  S IFN=$O(^OR(100,"AS",ORVP,TM,IFN)) Q:IFN<1  D
     124 . . S ACT=0 F  S ACT=$O(^OR(100,"AS",ORVP,TM,IFN,ACT)) Q:ACT<1  D
     125 . . . Q:$D(HAVE(IFN_";"_ACT))                        ;in Changes
     126 . . . S X8=$G(^OR(100,IFN,8,ACT,0))
     127 . . . I '$S(LVL=1&($P(X8,U,3)=DUZ):1,LVL=2:1,1:0) Q  ;chk user
     128 . . . S ILST=ILST+1,LST(ILST)=IFN_";"_ACT
     129 Q
     130PKIUSE(RETURN) ; RPC determines user can use PKI Digital Signature
     131 S RETURN=0
     132 I $$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q") S RETURN=1
     133 Q
     134PKISITE(RETURN) ; RPC determines if PKI is turned on at the site
     135 S RETURN=0
     136 Q:'$L($T(STORESIG^XUSSPKI))  ;Check for Kernel piece
     137 Q:'$L($T(DOSE^PSSOPKI1))  ;Check for Pharmacy piece
     138 I $$GET^XPAR("ALL","ORWOR PKI SITE",1,"Q") S RETURN=1
     139 Q
     140ACTXT(ORY,ORIFN) ;Return detail action information
     141 N ORI,CNT,OR0,OR3,OR6
     142 K ^TMP("ORACTXT",$J)
     143 S ORY="^TMP(""ORACTXT"",$J)",ORI=$P(ORIFN,";",2)
     144 S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6))
     145 F  S ORI=$O(^OR(100,+ORIFN,8,ORI)) Q:ORI'>0  S ACTION=$G(^(ORI,0)) D ACT^ORQ20
     146 S ORY=$NA(^TMP("ORACTXT",$J)),@ORY=""
     147 Q
     148EXPIRED(ORY) ;return FM date/time to begin search for expired orders
     149 N HRS
     150 S HRS=$$GET^XPAR("ALL","ORWOR EXPIRED ORDERS",1,"I")
     151 S ORY=$$FMADD^XLFDT($$NOW^XLFDT,"","-"_HRS,"","")
     152 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORB.m

    r613 r623  
    1 ORWORB  ; slc/dee/REV/CLA - RPC functions which return user alert ;10:12 am JAN 31, 2001
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,148,173,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 URGENLST(ORY)   ;return array of the  urgency for the notification
    5         N ORSRV,ORERROR
    6         S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
    7         D GETLST^XPAR(.ORY,"USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORB URGENCY","I",.ORERROR)
    8         Q
    9         ;
    10 FASTUSER(ORY)   ;return current user's notifications across all patients
    11         N STRTDATE,STOPDATE,ORTOT,I,ORURG,URG,ORN,SORT,ORN0,URGLIST,REMLIST,REM,NONORLST,NONOR
    12         N ALRT,ALRTDT,ALRTPT,ALRTMSG,ALRTI,ALRTLOC,ALRTXQA,J,FWDBY,PRE,ALRTDFN
    13         K ^TMP("ORBG",$J)
    14         S STRTDATE="",STOPDATE="",FWDBY="Forwarded by: "
    15         D GETUSER1^XQALDATA("^TMP(""ORB"",$J)",DUZ,STRTDATE,STOPDATE)
    16         S ORTOT=^TMP("ORB",$J)
    17         D URGLIST^ORQORB(.URGLIST)
    18         D REMLIST^ORQORB(.REMLIST)
    19         D REMNONOR^ORQORB(.NONORLST)
    20         S J=0
    21         F I=1:1:ORTOT D
    22         .S ALRTDFN=""
    23         .S ALRT=^TMP("ORB",$J,I)
    24         .S PRE=$E(ALRT,1,1)
    25         .S ALRTXQA=$P(ALRT,U,2)  ;XQAID
    26         .S NONOR="" F  S NONOR=$O(NONORLST(NONOR)) Q:NONOR=""  D
    27         ..I ALRTXQA[NONOR S REM=1  ;allow this type of alert to be Removed
    28         .S ALRTMSG=$P($P(ALRT,U),PRE_"  ",2)
    29         .I $E(ALRT,4,8)'="-----" D  ;not forwarded alert info/comment
    30         ..S ORURG="n/a"
    31         ..S ALRTI=$P(ALRT,"  ")
    32         ..S ALRTPT=""
    33         ..S ALRTLOC=""
    34         ..I $E($P(ALRTXQA,";"),1,3)="TIU" S ORURG="Moderate"
    35         ..I $P(ALRTXQA,",")="OR" D
    36         ...S ORN=$P($P(ALRTXQA,";"),",",3)
    37         ...S URG=$G(URGLIST(ORN))
    38         ...S ORURG=$S(URG=1:"HIGH",URG=2:"Moderate",1:"low")
    39         ...S REM=$G(REMLIST(ORN))
    40         ...S ORN0=^ORD(100.9,ORN,0)
    41         ...S ALRTI=$S($P(ORN0,U,6)="INFODEL":"I",1:"")
    42         ...S ALRTDFN=$P(ALRTXQA,",",2)
    43         ...S ALRTLOC=$G(^DPT(+$G(ALRTDFN),.1))
    44         ..S ALRTI=$S(ALRTI="I":"I",1:"")
    45         ..I ALRT["): " D
    46         ...S ALRTPT=$P(ALRT,": ")
    47         ...S ALRTPT=$E(ALRTPT,4,$L(ALRTPT))
    48         ...S ALRTMSG=$P($P(ALRT,U),"): ",2)
    49         ...I $E(ALRTMSG,1,1)="[" D
    50         ....S:'$L(ALRTLOC) ALRTLOC=$P($P(ALRTMSG,"]"),"[",2)
    51         ....S ALRTMSG=$P(ALRTMSG,"] ",2)
    52         ..I '$L($G(ALRTPT)) S ALRTPT="no patient"
    53         ..S ALRTDT=$P(ALRTXQA,";",3)
    54         ..S ALRTDT=$P(ALRTDT,".")_"."_$E($P(ALRTDT,".",2)_"0000",1,4)
    55         ..S ALRTDT=$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"/"_($E(ALRTDT,1,3)+1700)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4)
    56         ..;S ALRTDT=($E(ALRTDT,1,3)+1700)_"/"_$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4)
    57         ..S J=J+1,^TMP("ORBG",$J,J)=ALRTI_U_ALRTPT_U_ALRTLOC_U_ORURG_U_ALRTDT_U
    58         ..S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_ALRTMSG_U_U_ALRTXQA_U_$G(REM)_U
    59         .;
    60         .;if alert forward info/comment:
    61         .I $E(ALRTMSG,1,5)="-----" D
    62         ..S ALRTMSG=$P(ALRTMSG,"-----",2)
    63         ..I $E(ALRTMSG,1,14)=FWDBY D
    64         ...S J=J+1,^TMP("ORBG",$J,J)=FWDBY_U_$P($P(ALRTMSG,FWDBY,2),"Generated: ")_$P($P(ALRTMSG,FWDBY,2),"Generated: ",2)
    65         ..E  S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_U_""""_ALRTMSG_""""
    66         S ^TMP("ORBG",$J)=""
    67         S ORY=$NA(^TMP("ORBG",$J))
    68         Q
    69         ;
    70 GETDATA(ORY,XQAID)      ; return XQADATA for an alert
    71         N SHOWADD
    72         S ORY=""
    73         Q:$G(XQAID)=""!('$D(^XTV(8992,"AXQA",XQAID)))
    74         D GETACT^XQALERT(XQAID)
    75         S ORY=XQADATA
    76         I ($E(XQAID,1,3)="TIU"),(+ORY>0) D
    77         . S SHOWADD=1
    78         . S ORY=ORY_$$RESOLVE^TIUSRVLO(+ORY)
    79         K XQAID,XQADATA,XQAOPT,XQAROU
    80         Q
    81         ;
    82 KILUNSNO(Y,ORVP)        ; Delete unsigned order alerts if no unsigned orders remaining
    83         S ORVP=ORVP_";DPT("
    84         D UNOTIF^ORCSIGN
    85         Q
    86         ;
    87 UNFLORD(ORY,DFN,XQAID)  ; -- auto-unflag orders?/delete alert
    88         Q:'$L(DFN)!('$L(XQAID))
    89         N ORI,ORIFN,ORA,XQAKILL,ORN,ORBY,ORAUTO,ORUNF
    90         S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0))
    91         S XQAKILL=$$XQAKILL^ORB3F1(ORN)
    92         D LIST^ORQOR1(.ORBY,DFN,"ALL",12,"","")
    93         S ORAUTO=+$$GET^XPAR("ALL","ORPF AUTO UNFLAG")
    94         S ORI=0 F  S ORI=$O(ORBY(ORI)) Q:ORI'>0  D
    95         . I ORAUTO D  ; unflag
    96         . . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged"
    97         . . S ORIFN=$P(ORBY(ORI),U),ORA=+$P(ORIFN,";",2)
    98         . . I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF D MSG^ORCFLAG(ORIFN) ; unflag
    99         I ORAUTO!(+$G(ORBY(1))=0) D DELETE^XQALERT
    100         Q
    101 KILEXMED(Y,ORDFN)        ; -- Delete expiring meds notification if no expiring meds remaining
    102         N ORDG,ORLST S ORDG=$$DG^ORQOR1("RX")
    103         D AGET^ORWORR(.ORLST,ORDFN,5,ORDG)
    104         Q:+(@ORLST@(.1))  ;more left
    105         N XQAKILL,ORNIFN,ORVP,ORIO S OROI=""
    106         F OROI="INPT","OUTPT" D
    107         .S ORNIFN=$O(^ORD(100.9,"B","MEDICATIONS EXPIRING - "_OROI,0)),ORVP=ORDFN_";DPT("
    108         .Q:'$L($G(ORNIFN))
    109         .S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; expiring meds notif
    110         .I $D(XQAID) D DELETE^XQALERT
    111         .I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
    112         Q
    113 KILEXOI(Y,ORDFN,ORNIFN)  ; -- Delete expiring flagged OI notification if no flagged expiring OI remaining
    114         N ORDG,ORLST S ORDG=$$DG^ORQOR1("ALL")
    115         D AGET^ORWORR(.ORLST,ORDFN,5,ORDG)
    116         Q:+(@ORLST@(.1))  ;more left
    117         N XQAKILL,ORVP
    118         S ORVP=ORDFN_";DPT("
    119         S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; flagged expiring OI notifications
    120         I $D(XQAID) D DELETE^XQALERT
    121         I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
    122         Q
    123 KILUNVOR(Y,ORDFN)        ; -- Delete UNVERIFIED ORDER notification if none remaining within current admission/30 days
    124         N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("ALL")
    125         S OREDT=$$NOW^XLFDT
    126         S ORDDT=$$FMADD^XLFDT(OREDT,"-90")
    127         ;get current admission date/time:
    128         S DFN=ORDFN,VA200="" D INP^VADPT
    129         S ORBDT=$P($G(VAIN(7)),U)
    130         S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT)  ;<= if no admission use past 30 days
    131         S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT)  ;max past days to use is 90 days
    132         D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT)
    133         Q:+(@ORLST@(.1))  ;more left
    134         N XQAKILL,ORVP,ORNIFN
    135         S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED ORDER",0)),ORVP=ORDFN_";DPT("
    136         S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN)
    137         I $D(XQAID) D DELETE^XQALERT
    138         I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
    139         Q
    140 KILUNVMD(Y,ORDFN)        ; -- Delete UNVERIFIED MEDS notification if none remaining within current admission/30 days
    141         N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("RX")
    142         S OREDT=$$NOW^XLFDT
    143         S ORDDT=$$FMADD^XLFDT(OREDT,"-90")
    144         ;get current admission date/time:
    145         S DFN=ORDFN,VA200="" D INP^VADPT
    146         S ORBDT=$P($G(VAIN(7)),U)
    147         S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT)  ;<= if no admission use past 30 days
    148         S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT)  ;max past days to use is 90 days
    149         D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT)
    150         Q:+(@ORLST@(.1))  ;more left
    151         N XQAKILL,ORVP,ORNIFN
    152         S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED MEDICATION ORDER",0)),ORVP=ORDFN_";DPT("
    153         S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN)
    154         I $D(XQAID) D DELETE^XQALERT
    155         I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
    156         Q
    157 ESORD(ORY,XQAID)          ;order(s) requiring electronic signature follow-up
    158         K XQAKILL
    159         N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL
    160         S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0
    161         S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
    162         S ORDG=$$DG^ORQOR1("ALL")
    163         ;the FLG code for UNSIGNED orders in ORQ1 is '11'
    164         ;get unsigned orders - if none exist, delete alert then quit:
    165         D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0)
    166         S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""  I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
    167         ;
    168         ;user does not have ORES key, delete user's alert:
    169         I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
    170         ;
    171         ;if prov is NOT linked to pt via attending, primary or teams:
    172         I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D
    173         .S ORX="" F  S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1)  D
    174         ..S ORZ="" F  S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+ORZ=0!(ORDERS=1)  D
    175         ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
    176         ...;quit if this unsigned order's last action was made by the user
    177         ...I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1
    178         .I ORDERS'=1 D  ;provider has no outstanding unsigned orders for pt
    179         ..S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID)  ;delete alert for this user
    180         K ^TMP("ORR",$J)
    181         Q
    182         ;
    183 TXTFUP(ROOT,DFN,NOTIF,XQADATA)  ; Follow-up for text messages
    184         ;
    185         I NOTIF=67 D CHGRAD
    186         Q
    187         ;
    188 CHGRAD  ;GUI follow-up for Imaging Request Changed (#67)
    189         S ROOT=$NA(^TMP($J,"RAE4"))
    190         K @ROOT
    191         D SET1^RAO7PC4  ;DBIA #3563
    192         Q
    193         ;
    194 GETSORT(ORY)    ;return notification sort method^direction for user/division/system/pkg
    195         S ORY=$$GET^XPAR("ALL","ORB SORT METHOD",1,"I")_U_$$GET^XPAR("ALL","ORB SORT DIRECTION",1,"I")
    196         Q
    197         ;
    198 SETSORT(ORERR,SORT,DIR) ;set notification sort method^direction for user
    199         D EN^XPAR(DUZ_";VA(200,","ORB SORT METHOD",1,SORT,.ORERR)
    200         I $L($G(DIR)) D EN^XPAR(DUZ_";VA(200,","ORB SORT DIRECTION",1,DIR,.ORERR)
    201         Q
     1ORWORB ; slc/dee/REV/CLA - RPC functions which return user alert ;10:12 am JAN 31, 2001
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,148,173,190,215**;Dec 17, 1997
     3 ;
     4URGENLST(ORY) ;return array of the  urgency for the notification
     5 N ORSRV,ORERROR
     6 S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
     7 D GETLST^XPAR(.ORY,"USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORB URGENCY","I",.ORERROR)
     8 Q
     9 ;
     10FASTUSER(ORY) ;return current user's notifications across all patients
     11 N STRTDATE,STOPDATE,ORTOT,I,ORURG,URG,ORN,SORT,ORN0,URGLIST,REMLIST,REM,NONORLST,NONOR
     12 N ALRT,ALRTDT,ALRTPT,ALRTMSG,ALRTI,ALRTLOC,ALRTXQA,J,FWDBY,PRE,ALRTDFN
     13 K ^TMP("ORBG",$J)
     14 S STRTDATE="",STOPDATE="",FWDBY="Forwarded by: "
     15 D GETUSER1^XQALDATA("^TMP(""ORB"",$J)",DUZ,STRTDATE,STOPDATE)
     16 S ORTOT=^TMP("ORB",$J)
     17 D URGLIST^ORQORB(.URGLIST)
     18 D REMLIST^ORQORB(.REMLIST)
     19 D REMNONOR^ORQORB(.NONORLST)
     20 S J=0
     21 F I=1:1:ORTOT D
     22 .S ALRTDFN=""
     23 .S ALRT=^TMP("ORB",$J,I)
     24 .S PRE=$E(ALRT,1,1)
     25 .S ALRTXQA=$P(ALRT,U,2)  ;XQAID
     26 .S NONOR="" F  S NONOR=$O(NONORLST(NONOR)) Q:NONOR=""  D
     27 ..I ALRTXQA[NONOR S REM=1  ;allow this type of alert to be Removed
     28 .S ALRTMSG=$P($P(ALRT,U),PRE_"  ",2)
     29 .I $E(ALRT,4,8)'="-----" D  ;not forwarded alert info/comment
     30 ..S ORURG="n/a"
     31 ..S ALRTI=$P(ALRT,"  ")
     32 ..S ALRTPT=""
     33 ..S ALRTLOC=""
     34 ..I $E($P(ALRTXQA,";"),1,3)="TIU" S ORURG="Moderate"
     35 ..I $P(ALRTXQA,",")="OR" D
     36 ...S ORN=$P($P(ALRTXQA,";"),",",3)
     37 ...S URG=$G(URGLIST(ORN))
     38 ...S ORURG=$S(URG=1:"HIGH",URG=2:"Moderate",1:"low")
     39 ...S REM=$G(REMLIST(ORN))
     40 ...S ORN0=^ORD(100.9,ORN,0)
     41 ...S ALRTI=$S($P(ORN0,U,6)="INFODEL":"I",1:"")
     42 ...S ALRTDFN=$P(ALRTXQA,",",2)
     43 ...S ALRTLOC=$G(^DPT(+$G(ALRTDFN),.1))
     44 ..S ALRTI=$S(ALRTI="I":"I",1:"")
     45 ..I ALRT["): " D
     46 ...S ALRTPT=$P(ALRT,": ")
     47 ...S ALRTPT=$E(ALRTPT,4,$L(ALRTPT))
     48 ...S ALRTMSG=$P($P(ALRT,U),"): ",2)
     49 ...I $E(ALRTMSG,1,1)="[" D
     50 ....S:'$L(ALRTLOC) ALRTLOC=$P($P(ALRTMSG,"]"),"[",2)
     51 ....S ALRTMSG=$P(ALRTMSG,"] ",2)
     52 ..I '$L($G(ALRTPT)) S ALRTPT="no patient"
     53 ..S ALRTDT=$P(ALRTXQA,";",3)
     54 ..S ALRTDT=$P(ALRTDT,".")_"."_$E($P(ALRTDT,".",2)_"0000",1,4)
     55 ..S ALRTDT=$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"/"_($E(ALRTDT,1,3)+1700)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4)
     56 ..;S ALRTDT=($E(ALRTDT,1,3)+1700)_"/"_$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4)
     57 ..S J=J+1,^TMP("ORBG",$J,J)=ALRTI_U_ALRTPT_U_ALRTLOC_U_ORURG_U_ALRTDT_U
     58 ..S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_ALRTMSG_U_U_ALRTXQA_U_$G(REM)_U
     59 .;
     60 .;if alert forward info/comment:
     61 .I $E(ALRTMSG,1,5)="-----" D
     62 ..S ALRTMSG=$P(ALRTMSG,"-----",2)
     63 ..I $E(ALRTMSG,1,14)=FWDBY D
     64 ...S J=J+1,^TMP("ORBG",$J,J)=FWDBY_U_$P($P(ALRTMSG,FWDBY,2),"Generated: ")_$P($P(ALRTMSG,FWDBY,2),"Generated: ",2)
     65 ..E  S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_U_""""_ALRTMSG_""""
     66 S ^TMP("ORBG",$J)=""
     67 S ORY=$NA(^TMP("ORBG",$J))
     68 Q
     69 ;
     70GETDATA(ORY,XQAID) ; return XQADATA for an alert
     71 N SHOWADD
     72 S ORY=""
     73 Q:$G(XQAID)=""!('$D(^XTV(8992,"AXQA",XQAID)))
     74 D GETACT^XQALERT(XQAID)
     75 S ORY=XQADATA
     76 I ($E(XQAID,1,3)="TIU"),(+ORY>0) D
     77 . S SHOWADD=1
     78 . S ORY=ORY_$$RESOLVE^TIUSRVLO(+ORY)
     79 K XQAID,XQADATA,XQAOPT,XQAROU
     80 Q
     81 ;
     82KILUNSNO(Y,ORVP) ; Delete unsigned order alerts if no unsigned orders remaining
     83 S ORVP=ORVP_";DPT("
     84 D UNOTIF^ORCSIGN
     85 Q
     86 ;
     87UNFLORD(Y,DFN,XQAID) ; -- auto-unflag orders?/delete alert
     88 Q:'$L(DFN)!('$L(XQAID))
     89 N ORI,ORIFN,ORA,XQAKILL,ORN,ORBY,ORAUTO,ORUNF
     90 S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0))
     91 S XQAKILL=$$XQAKILL^ORB3F1(ORN)
     92 D LIST^ORQOR1(.ORBY,DFN,"ALL",12,"","")
     93 S ORAUTO=+$$GET^XPAR("ALL","ORPF AUTO UNFLAG")
     94 S ORI=0 F  S ORI=$O(ORBY(ORI)) Q:ORI'>0  D
     95 . I ORAUTO D  ; unflag
     96 . . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged"
     97 . . S ORIFN=$P(ORBY(ORI),U),ORA=+$P(ORIFN,";",2)
     98 . . I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF ; unflag
     99 I ORAUTO!(+$G(ORBY(1))=0) D DELETE^XQALERT
     100 Q
     101KILEXMED(Y,ORDFN)  ; -- Delete expiring meds notification if no expiring meds remaining
     102 N ORDG,ORLST S ORDG=$$DG^ORQOR1("RX")
     103 D AGET^ORWORR(.ORLST,ORDFN,5,ORDG)
     104 Q:+(@ORLST@(.1))  ;more left
     105 N XQAKILL,ORNIFN,ORVP,ORIO S OROI=""
     106 F OROI="INPT","OUTPT" D
     107 .S ORNIFN=$O(^ORD(100.9,"B","MEDICATIONS EXPIRING - "_OROI,0)),ORVP=ORDFN_";DPT("
     108 .Q:'$L($G(ORNIFN))
     109 .S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; expiring meds notif
     110 .I $D(XQAID) D DELETE^XQALERT
     111 .I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
     112 Q
     113KILEXOI(Y,ORDFN,ORNIFN)  ; -- Delete expiring flagged OI notification if no flagged expiring OI remaining
     114 N ORDG,ORLST S ORDG=$$DG^ORQOR1("ALL")
     115 D AGET^ORWORR(.ORLST,ORDFN,5,ORDG)
     116 Q:+(@ORLST@(.1))  ;more left
     117 N XQAKILL,ORVP
     118 S ORVP=ORDFN_";DPT("
     119 S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; flagged expiring OI notifications
     120 I $D(XQAID) D DELETE^XQALERT
     121 I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
     122 Q
     123KILUNVOR(Y,ORDFN)  ; -- Delete UNVERIFIED ORDER notification if none remaining within current admission/30 days
     124 N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("ALL")
     125 S OREDT=$$NOW^XLFDT
     126 S ORDDT=$$FMADD^XLFDT(OREDT,"-90")
     127 ;get current admission date/time:
     128 S DFN=ORDFN,VA200="" D INP^VADPT
     129 S ORBDT=$P($G(VAIN(7)),U)
     130 S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT)  ;<= if no admission use past 30 days
     131 S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT)  ;max past days to use is 90 days
     132 D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT)
     133 Q:+(@ORLST@(.1))  ;more left
     134 N XQAKILL,ORVP,ORNIFN
     135 S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED ORDER",0)),ORVP=ORDFN_";DPT("
     136 S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN)
     137 I $D(XQAID) D DELETE^XQALERT
     138 I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
     139 Q
     140KILUNVMD(Y,ORDFN)  ; -- Delete UNVERIFIED MEDS notification if none remaining within current admission/30 days
     141 N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("RX")
     142 S OREDT=$$NOW^XLFDT
     143 S ORDDT=$$FMADD^XLFDT(OREDT,"-90")
     144 ;get current admission date/time:
     145 S DFN=ORDFN,VA200="" D INP^VADPT
     146 S ORBDT=$P($G(VAIN(7)),U)
     147 S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT)  ;<= if no admission use past 30 days
     148 S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT)  ;max past days to use is 90 days
     149 D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT)
     150 Q:+(@ORLST@(.1))  ;more left
     151 N XQAKILL,ORVP,ORNIFN
     152 S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED MEDICATION ORDER",0)),ORVP=ORDFN_";DPT("
     153 S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN)
     154 I $D(XQAID) D DELETE^XQALERT
     155 I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID
     156 Q
     157ESORD(ORY,XQAID)   ;order(s) requiring electronic signature follow-up
     158 K XQAKILL
     159 N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL
     160 S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0
     161 S ORPT=$P($P(XQAID,";"),",",2)  ;get pt dfn from xqaid
     162 S ORDG=$$DG^ORQOR1("ALL")
     163 ;the FLG code for UNSIGNED orders in ORQ1 is '11'
     164 ;get unsigned orders - if none exist, delete alert then quit:
     165 D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0)
     166 S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""  I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
     167 ;
     168 ;user does not have ORES key, delete user's alert:
     169 I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q
     170 ;
     171 ;if prov is NOT linked to pt via attending, primary or teams:
     172 I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D
     173 .S ORX="" F  S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1)  D
     174 ..S ORZ="" F  S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+ORZ=0!(ORDERS=1)  D
     175 ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
     176 ...;quit if this unsigned order's last action was made by the user
     177 ...I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1
     178 .I ORDERS'=1 D  ;provider has no outstanding unsigned orders for pt
     179 ..S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID)  ;delete alert for this user
     180 K ^TMP("ORR",$J)
     181 Q
     182 ;
     183TXTFUP(ROOT,DFN,NOTIF,XQADATA) ; Follow-up for text messages
     184 ;
     185 I NOTIF=67 D CHGRAD
     186 Q
     187 ;
     188CHGRAD ;GUI follow-up for Imaging Request Changed (#67)
     189 S ROOT=$NA(^TMP($J,"RAE4"))
     190 K @ROOT
     191 D SET1^RAO7PC4  ;DBIA #3563
     192 Q
     193 ;
     194GETSORT(ORY) ;return notification sort method^direction for user/division/system/pkg
     195 S ORY=$$GET^XPAR("ALL","ORB SORT METHOD",1,"I")_U_$$GET^XPAR("ALL","ORB SORT DIRECTION",1,"I")
     196 Q
     197 ;
     198SETSORT(ORERR,SORT,DIR) ;set notification sort method^direction for user
     199 D EN^XPAR(DUZ_";VA(200,","ORB SORT METHOD",1,SORT,.ORERR)
     200 I $L($G(DIR)) D EN^XPAR(DUZ_";VA(200,","ORB SORT DIRECTION",1,DIR,.ORERR)
     201 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR.m

    r613 r623  
    1 ORWORR  ; SLC/KCM/JLI - Retrieve Orders for Broker ;7/24/05
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 GET(LST,DFN,FILTER,GROUPS)      ; procedure
    5         Q  ; don't call until using same treating specialty logic as AGET
    6         ;    & until MULT, ORWARD, & ORIGVIEW implemented
    7         ;    & until the date ranges implemented
    8         ; Get orders for patient
    9         ;        1   2    3     4      5     6   7   8   9   10     11    12    13    14     15     16 17    18
    10         ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule
    11         ; .LST=tOrder Text (repeating as necessary)
    12         ;     DFN=Patient ID
    13         ;  FILTER=# indicates which orders to return, default=2 (current)
    14         ;  GROUPS=display grp of orders to show (default=ALL)
    15         ; -- section uses ORQ1 to get orders list rather than XGET --
    16         N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI
    17         K ^TMP("ORR",$J)
    18         S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2
    19         D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1)
    20         S EYE=0 F  S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE  S IFN=^(EYE) D
    21         . S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0)
    22         . D GETFLDS
    23         K ^TMP("ORR",$J)
    24         G EXIT
    25 AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT,ORRECIP) ;Get abbrev. event delayed order list for patient
    26         ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm
    27         ; see input parameters above
    28         ; -- from ORWORR
    29         ; -- section uses ORQ1 to get orders list rather than XGET --
    30         N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME
    31         S (PTEVTID,EVTNAME)=""
    32         K ^TMP("ORR",$J),^TMP("ORRJD",$J)
    33         S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2
    34         S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER
    35         S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_FILTER_U):1,1:0)
    36         I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42
    37         S:'$L($G(DTFROM)) DTFROM=0
    38         S:'$L($G(DTTHRU)) DTTHRU=0
    39         I $P(DTFROM,".")=$P(DTTHRU,"."),$P(DTFROM,".",2)>$P(DTTHRU,".",2),$P(DTTHRU,".",2)="" S $P(DTTHRU,".",2)=2359
    40         S:'$L($G(EVENT)) EVENT=0
    41         I $G(EVTDCREL)="TRUE" D
    42         . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT)
    43         . D GET2^ORWORR1
    44         E  D
    45         . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT)
    46         . D GET1^ORWORR1
    47         Q
    48 RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event
    49         N EVTDCREL
    50         S EVTDCREL="TRUE"
    51         D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT)
    52         Q
    53 XGET    ; retrieval algorithm before all the AC xref changes
    54         N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI
    55         S DFN=DFN_";DPT(",IDX=0,LST=0
    56         I '$G(FILTER) S FILTER=2                    ; Default: Current/Active
    57         I $D(GROUPS)=1 D
    58         . S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0))
    59         . D XPND(GROUPS)
    60         I FILTER=1  D DOALL G EXIT                  ; All
    61         I FILTER=2  D DOCUR G EXIT                  ; Current
    62         I FILTER=3  S PASS=";1;"                    ; Discontinued
    63         I FILTER=4  S PASS=";2;7;"                  ; Comp/Expired
    64         I FILTER=5  S PASS=";3;4;5;6;8;9;"          ; Expiring
    65         I FILTER=6  S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity
    66         I FILTER=7  S PASS=";5;"                    ; Pending
    67         I FILTER=8  Q                               ; Expanded
    68         I FILTER=9  S PASS=";3;4;5;6;8;9;11;"       ; Unverified by Nurse
    69         I FILTER=10 S PASS=";3;4;5;6;8;9;11;"       ; Unverified by Clerk
    70         I FILTER=11 S PASS=";3;4;5;6;7;8;11;"       ; Unsigned
    71         I FILTER=12 S PASS=";4;"                    ; Flagged
    72         I FILTER=13 S PASS=""                       ; Verbal/Phone
    73         I FILTER=14 S PASS=""                       ; Verbal/Phone Unsigned
    74         D DOGET
    75 EXIT    I LST=0 D
    76         . N %,X,%I D NOW^%DTC
    77         . S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found."
    78         Q
    79 DOGET   ; Here to filter orders
    80         S TIME=0 F  S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME  D
    81         . S DGRP=0 F  S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP  D
    82         . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP))           ;filter by display grp
    83         . . S IFN=0 F  S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN  D
    84         . . . S X0=^OR(100,IFN,0),X3=^(3)                ;get main nodes
    85         . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q  ;skip veil,chld,sts=99
    86         . . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q  ;filter by status
    87         . . . ; any other filtering
    88         . . . D GETFLDS
    89         Q
    90 DOALL   ; Here to get all orders (no filter by status)
    91         S TIME=0 F  S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME  D
    92         . S DGRP=0 F  S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP  D
    93         . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP))           ;filter by display grp
    94         . . S IFN=0 F  S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN  D
    95         . . . S X0=^OR(100,IFN,0),X3=^(3)                ;get main nodes
    96         . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q  ;skip veil,chld,sts=99
    97         . . . D GETFLDS
    98         Q
    99 DOCUR   ; Here to get all current orders
    100         N AOCTXT,STS,STOP,%
    101         S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS")
    102         S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400)
    103         D YMD^%DTC S AOCTXT=X_%
    104         S MASK="110000100101110"   ; mask out STS=1,2,7,10,12,13,14
    105         S TIME=0 F  S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME  D
    106         . S IFN=0 F  S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN  D
    107         . . ; filter out display groups here
    108         . . S ACT=0 F  S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT  D
    109         . . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0)
    110         . . . S STS=$P(X3,U,3),STOP=$P(X0,U,9)
    111         . . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q
    112         . . . I $P(X8,U,15)=13,($P(X8,U)<AOCTXT) D ACKILL Q
    113         . . . I $P(X8,U,15)=13!($P(X8,U,15)=""),("RN^XX"[$P(X8,U,2)) D ACKILL Q
    114         . . . I $E(MASK,STS),STOP<AOCTXT D ACKILL Q
    115         . . . D GETFLDS
    116         Q
    117 ACKILL  ; called only from DOCUR - kill AC xref
    118         ; K ^OR(100,"AC",DFN,TIME,IFN,ACT)  ; let ORQ1 kill if for now
    119         Q
    120 GET4V11(LST,TXTVW,ORYD,IFNLST)  ; get order fields TEMP
    121         G GET41
    122 GET4LST(LST,IFNLST)     ; get order fields for list of orders
    123 GET41   N ACT,ACTID,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,IFN,IFNIDX,ORIGVIEW,DEA ;PKI
    124         N LOC ;IMO
    125         S (IDX,LST,IFNIDX)=0
    126         F  S IFNIDX=$O(IFNLST(IFNIDX)) Q:'IFNIDX  S IFN=IFNLST(IFNIDX) D
    127         . S ACT=$S($P(IFN,";",2):$P(IFN,";",2),1:1),IFN=+IFN
    128         . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACT,0))
    129         . D GETFLDS
    130         Q
    131 GETBYIFN(LST,IFN)       ; procedure
    132         ; get fields for single order
    133         ; .LST(n)=described above in GET
    134         ;  IFN=internal entry # for order
    135         I 'IFN Q
    136         N ACT,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,ACTID,ORIGVIEW,ORYD,TXTVW,DEA ;PKI
    137         S IDX=0,LST=0,ORYD=0
    138         S X0=$G(^OR(100,+IFN,0)),X3=$G(^(3))
    139         S ACT=$S($P(IFN,";",2):$P(IFN,";",2),$P(X3,U,7):$P(X3,U,7),1:1)
    140         S IFN=+IFN,X8=$G(^OR(100,IFN,8,ACT,0))
    141 GETFLDS ; used by entry points to place order fields into list
    142         ; expects IDX=sequence #, IFN=order, X0=node 0, X3=node 3, LST=results
    143         ; LST(IDX)=~IFN^Grp^OrdTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^Act^Flagged[^DCType]^ChartRev^DEA#^^DigSig^LOC
    144         S PRV=$P(X8,U,5) S:'PRV PRV=$P(X8,U,3) S PRV=PRV_U
    145         I PRV S PRV=PRV_$P(^VA(200,+PRV,0),U)
    146         S DEA=$$DEA^XUSER(,+PRV) ; get user DEA info - PKI
    147         S IDX=IDX+1,LST=LST+1,ID=IFN_";"_ACT,ACTID=$P(X8,U,2)
    148         S CSTS=$S($P(X8,U,15):$P(X8,U,15),1:$P(X3,U,3))
    149         I $P(X8,U,15)=10,$P(X3,U,3)=14 S CSTS=14 ;delayed-lapsed order
    150         S STRT=$S($P(X3,U,3)=11:$$RSTRT,ACTID="NW"!(ACTID="XX")!(ACTID="RL"):$P(X0,U,8),ACTID="DC":"",1:$P(X8,U)) ;110
    151         S STOP=$S($P(X3,U,3)=11:$$RSTOP,ACTID="HD":$P($G(^OR(100,+IFN,8,ACT,2)),U),1:$P(X0,U,9))
    152         S LST(IDX)="~"_ID_U_$P(X0,U,11)_U_$P(X8,U)_U_STRT_U_STOP_U_CSTS_U_$P(X8,U,4)_U_$P(X8,U,8)_U_$P(X8,U,10)_U_PRV
    153         S $P(LST(IDX),U,13)=+$G(^OR(100,IFN,8,ACT,3))    ; flagged
    154         I +$P(X8,U,8) S $P(LST(IDX),U,8)=$$INITIALS^ORCHTAB2(+$P(X8,U,8))    ;nurse
    155         I +$P(X8,U,10) S $P(LST(IDX),U,9)=$$INITIALS^ORCHTAB2(+$P(X8,U,10))  ;clerk
    156         I +$P(X8,U,18) S $P(LST(IDX),U,15)=$$INITIALS^ORCHTAB2(+$P(X8,U,18)) ;chart review
    157         I $L($G(DEA)) S $P(LST(IDX),U,16)=DEA ;PKI
    158         I $P($G(^OR(100,IFN,8,ACT,2)),"^",5) S $P(LST(IDX),U,18)=$P(^(2),"^",4)
    159         I '$P($G(^OR(100,IFN,8,ACT,2)),"^",5),$P(X0,"^",5) D  ;Copy orders PKI fix
    160         . N OI,ORVP,ORCAT,PKG
    161         . S OI=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,IFN,4.5,OI,1)) Q:'OI
    162         . S ORVP=$P(X0,"^",2),PKG=$P(X0,"^",14)
    163         . S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
    164         . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
    165         . D PKI^ORWDPS1(.ORY,OI,ORCAT,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))
    166         . I $E($G(ORY))=2 S $P(LST(IDX),U,18)=ORY
    167         ; Change to display location for Clinic Orders, Inpatients, & IV infusion orders.
    168         N DGID,DGNAM
    169         S LOC=""
    170         S DGID=$P(X0,U,11)
    171         I $L(DGID) D
    172         .S DGNAM=$P($G(^ORD(100.98,DGID,0)),U)
    173         .;I DGNAM="CLINIC ORDERS"!(DGNAM="INPATIENT MEDICATIONS")!(DGNAM="IV MEDICATIONS")!(DGNAM="UNIT DOSE MEDICATIONS") D
    174         .S LOC=$P(X0,U,10) ;IMO
    175         .S:+LOC LOC=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO
    176         S $P(LST(IDX),U,19)=LOC ;IMO
    177         ;
    178         S ORIGVIEW=$S($G(TXTVW)=0:0,$G(TXTVW)=1:1,ORYD=-1:1,'ORYD:1,$P(X8,U)'<ORYD:0,1:1)
    179         K TXT D TEXT^ORQ12(.TXT,ID,255)                  ; optimize later
    180         I $O(^OR(100,+IFN,2,0)) S LN=$O(TXT(0)),TXT(LN)="+"_TXT(LN)
    181         I $O(^OR(100,+IFN,8,"C","XX",0)) S LN=$O(TXT(0)),TXT(LN)="*"_TXT(LN)
    182         S LN=0 F  S LN=$O(TXT(LN)) Q:'LN  S IDX=IDX+1,LST(IDX)="t"_TXT(LN)
    183         I $O(^OR(100,+IFN,8,1,.2,0)) S IDX=IDX+1,LST(IDX)="|" D  ;PKI XMLText
    184         . S I=0 F  S I=$O(^OR(100,+IFN,8,1,.2,I)) Q:'I  S IDX=IDX+1,LST(IDX)="x"_^(I,0)
    185         Q
    186 RSTRT() ; return start date from responses
    187         Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","START",0)),1))
    188 RSTOP() ; return stop date from responses
    189         Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","STOP",0)),1))
    190 GETTXT(LST,IFN) ; get text of an order
    191         I $L(IFN,";")=1 S IFN=IFN_";1"
    192         D TEXT^ORQ12(.LST,IFN,255)
    193         Q
    194 XPND(AGRP)      ; procedure
    195         ; Expand display group (GROUPS defined outside of call)
    196         N I,CHLD
    197         S GROUPS(AGRP)=^ORD(100.98,AGRP,0),I=0
    198         F  S I=$O(^ORD(100.98,AGRP,1,I)) Q:'I  S CHLD=$P(^(I,0),U) D XPND(CHLD)
    199         Q
    200 GETPKG(Y,IFN)   ; get order pkg
    201         N ORDERID,PKGID
    202         Q:+IFN<1
    203         S ORDERID=+IFN,Y=""
    204         S PKGID=$P(OR(100,ORDERID,0),U,14)
    205         S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
    206         Q
     1ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ;7/24/05
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215**;Dec 17, 1997
     3 ;
     4GET(LST,DFN,FILTER,GROUPS) ; procedure
     5 Q  ; don't call until using same treating specialty logic as AGET
     6 ;    & until MULT, ORWARD, & ORIGVIEW implemented
     7 ;    & until the date ranges implemented
     8 ; Get orders for patient
     9 ;        1   2    3     4      5     6   7   8   9   10     11    12    13    14     15     16 17    18
     10 ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule
     11 ; .LST=tOrder Text (repeating as necessary)
     12 ;     DFN=Patient ID
     13 ;  FILTER=# indicates which orders to return, default=2 (current)
     14 ;  GROUPS=display grp of orders to show (default=ALL)
     15 ; -- this section uses ORQ1 to get orders list rather than XGET --
     16 N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI
     17 K ^TMP("ORR",$J)
     18 S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2
     19 D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1)
     20 S EYE=0 F  S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE  S IFN=^(EYE) D
     21 . S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0)
     22 . D GETFLDS
     23 K ^TMP("ORR",$J)
     24 G EXIT
     25AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Get an abbrev. event delayed order list for patient
     26 ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm
     27 ; see input parameters above
     28 ; -- from ORWORR
     29 ; -- section uses ORQ1 to get the orders list rather than XGET --
     30 N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME
     31 S (PTEVTID,EVTNAME)=""
     32 K ^TMP("ORR",$J),^TMP("ORRJD",$J)
     33 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2
     34 S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER
     35 S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_FILTER_U):1,1:0)
     36 I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42
     37 S:'$L($G(DTFROM)) DTFROM=0
     38 S:'$L($G(DTTHRU)) DTTHRU=0
     39 S:'$L($G(EVENT)) EVENT=0
     40 I $G(EVTDCREL)="TRUE" D
     41 . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT)
     42 . D GET2^ORWORR1
     43 E  D
     44 . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT)
     45 . D GET1^ORWORR1
     46 Q
     47RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event
     48 N EVTDCREL
     49 S EVTDCREL="TRUE"
     50 D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT)
     51 Q
     52XGET ; -- the retrieval algorithm before all the AC xref changes
     53 N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI
     54 S DFN=DFN_";DPT(",IDX=0,LST=0
     55 I '$G(FILTER) S FILTER=2                    ; Default: Current/Active
     56 I $D(GROUPS)=1 D
     57 . S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0))
     58 . D XPND(GROUPS)
     59 I FILTER=1  D DOALL G EXIT                  ; All
     60 I FILTER=2  D DOCUR G EXIT                  ; Current
     61 I FILTER=3  S PASS=";1;"                    ; Discontinued
     62 I FILTER=4  S PASS=";2;7;"                  ; Comp/Expired
     63 I FILTER=5  S PASS=";3;4;5;6;8;9;"          ; Expiring
     64 I FILTER=6  S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity
     65 I FILTER=7  S PASS=";5;"                    ; Pending
     66 I FILTER=8  Q                               ; Expanded
     67 I FILTER=9  S PASS=";3;4;5;6;8;9;11;"       ; Unverified by Nurse
     68 I FILTER=10 S PASS=";3;4;5;6;8;9;11;"       ; Unverified by Clerk
     69 I FILTER=11 S PASS=";3;4;5;6;7;8;11;"       ; Unsigned
     70 I FILTER=12 S PASS=";4;"                    ; Flagged
     71 I FILTER=13 S PASS=""                       ; Verbal/Phone
     72 I FILTER=14 S PASS=""                       ; Verbal/Phone Unsigned
     73 D DOGET
     74EXIT I LST=0 D
     75 . N %,X,%I D NOW^%DTC
     76 . S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found."
     77 Q
     78DOGET ; Come here to filter orders
     79 S TIME=0 F  S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME  D
     80 . S DGRP=0 F  S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP  D
     81 . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP))           ;filter by display grp
     82 . . S IFN=0 F  S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN  D
     83 . . . S X0=^OR(100,IFN,0),X3=^(3)                ;get main nodes
     84 . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q  ;skip veil,chld,sts=99
     85 . . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q  ;filter by status
     86 . . . ; do any other filtering
     87 . . . D GETFLDS
     88 Q
     89DOALL ; Come here to get all orders (no filter by status)
     90 S TIME=0 F  S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME  D
     91 . S DGRP=0 F  S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP  D
     92 . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP))           ;filter by display grp
     93 . . S IFN=0 F  S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN  D
     94 . . . S X0=^OR(100,IFN,0),X3=^(3)                ;get main nodes
     95 . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q  ;skip veil,chld,sts=99
     96 . . . D GETFLDS
     97 Q
     98DOCUR ; Come here to get all current orders
     99 N AOCTXT,STS,STOP,%
     100 S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS")
     101 S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400)
     102 D YMD^%DTC S AOCTXT=X_%
     103 S MASK="110000100101110"   ; mask out STS=1,2,7,10,12,13,14
     104 S TIME=0 F  S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME  D
     105 . S IFN=0 F  S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN  D
     106 . . ; filter out display groups here
     107 . . S ACT=0 F  S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT  D
     108 . . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0)
     109 . . . S STS=$P(X3,U,3),STOP=$P(X0,U,9)
     110 . . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q
     111 . . . I $P(X8,U,15)=13,($P(X8,U)<AOCTXT) D ACKILL Q
     112 . . . I $P(X8,U,15)=13!($P(X8,U,15)=""),("RN^XX"[$P(X8,U,2)) D ACKILL Q
     113 . . . I $E(MASK,STS),STOP<AOCTXT D ACKILL Q
     114 . . . D GETFLDS
     115 Q
     116ACKILL ; called only from DOCUR - kill AC xref
     117 ; K ^OR(100,"AC",DFN,TIME,IFN,ACT)  ; let ORQ1 kill if for now
     118 Q
     119GET4V11(LST,TXTVW,ORYD,IFNLST) ; get order fields TEMPORARY
     120 G GET41
     121GET4LST(LST,IFNLST)     ; get order fields for a list of orders
     122GET41 N ACT,ACTID,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,IFN,IFNIDX,ORIGVIEW,DEA ;PKI
     123 N LOC ;IMO
     124 S (IDX,LST,IFNIDX)=0
     125 F  S IFNIDX=$O(IFNLST(IFNIDX)) Q:'IFNIDX  S IFN=IFNLST(IFNIDX) D
     126 . S ACT=$S($P(IFN,";",2):$P(IFN,";",2),1:1),IFN=+IFN
     127 . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACT,0))
     128 . D GETFLDS
     129 Q
     130GETBYIFN(LST,IFN) ; procedure
     131 ; get fields for single order
     132 ; .LST(n)=as described above in GET
     133 ;     IFN=internal entry # for order
     134 I 'IFN Q
     135 N ACT,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,ACTID,ORIGVIEW,ORYD,TXTVW,DEA ;PKI
     136 S IDX=0,LST=0,ORYD=0
     137 S X0=$G(^OR(100,+IFN,0)),X3=$G(^(3))
     138 S ACT=$S($P(IFN,";",2):$P(IFN,";",2),$P(X3,U,7):$P(X3,U,7),1:1)
     139 S IFN=+IFN,X8=$G(^OR(100,IFN,8,ACT,0))
     140GETFLDS ; used by entry points to place order fields into list
     141 ; expects IDX=sequence #, IFN=order, X0=node 0, X3=node 3, LST=results
     142 ; LST(IDX)=~IFN^Grp^OrdTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^Act^Flagged[^DCType]^ChartRev^DEA#^^DigSig^LOC
     143 S PRV=$P(X8,U,5) S:'PRV PRV=$P(X8,U,3) S PRV=PRV_U
     144 I PRV S PRV=PRV_$P(^VA(200,+PRV,0),U)
     145 S DEA=$$DEA^XUSER(,+PRV) ; get user DEA info - PKI
     146 S IDX=IDX+1,LST=LST+1,ID=IFN_";"_ACT,ACTID=$P(X8,U,2)
     147 S CSTS=$S($P(X8,U,15):$P(X8,U,15),1:$P(X3,U,3))
     148 I $P(X8,U,15)=10,$P(X3,U,3)=14 S CSTS=14 ;delayed-lapsed order
     149 S STRT=$S($P(X3,U,3)=11:$$RSTRT,ACTID="NW"!(ACTID="XX")!(ACTID="RL"):$P(X0,U,8),ACTID="DC":"",1:$P(X8,U)) ;110
     150 S STOP=$S($P(X3,U,3)=11:$$RSTOP,ACTID="HD":$P($G(^OR(100,+IFN,8,ACT,2)),U),1:$P(X0,U,9))
     151 S LST(IDX)="~"_ID_U_$P(X0,U,11)_U_$P(X8,U)_U_STRT_U_STOP_U_CSTS_U_$P(X8,U,4)_U_$P(X8,U,8)_U_$P(X8,U,10)_U_PRV
     152 S $P(LST(IDX),U,13)=+$G(^OR(100,IFN,8,ACT,3))    ; flagged
     153 I +$P(X8,U,8) S $P(LST(IDX),U,8)=$$INITIALS^ORCHTAB2(+$P(X8,U,8))    ;nurse
     154 I +$P(X8,U,10) S $P(LST(IDX),U,9)=$$INITIALS^ORCHTAB2(+$P(X8,U,10))  ;clerk
     155 I +$P(X8,U,18) S $P(LST(IDX),U,15)=$$INITIALS^ORCHTAB2(+$P(X8,U,18)) ;chart review
     156 I $L($G(DEA)) S $P(LST(IDX),U,16)=DEA ;PKI
     157 I $P($G(^OR(100,IFN,8,ACT,2)),"^",5) S $P(LST(IDX),U,18)=$P(^(2),"^",4)
     158 I '$P($G(^OR(100,IFN,8,ACT,2)),"^",5),$P(X0,"^",5) D  ;Copy orders PKI fix
     159 . N OI,ORVP,ORCAT,PKG
     160 . S OI=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,IFN,4.5,OI,1)) Q:'OI
     161 . S ORVP=$P(X0,"^",2),PKG=$P(X0,"^",14)
     162 . S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
     163 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
     164 . D PKI^ORWDPS1(.ORY,OI,ORCAT,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))
     165 . I $E($G(ORY))=2 S $P(LST(IDX),U,18)=ORY
     166 ; Change code to display location for Clinic Orders, Inpatients, and IV infusion orders.
     167 N DGID,DGNAM
     168 S LOC=""
     169 S DGID=$P(X0,U,11)
     170 I $L(DGID) D
     171 .S DGNAM=$P($G(^ORD(100.98,DGID,0)),U)
     172 .;I DGNAM="CLINIC ORDERS"!(DGNAM="INPATIENT MEDICATIONS")!(DGNAM="IV MEDICATIONS")!(DGNAM="UNIT DOSE MEDICATIONS") D
     173 .S LOC=$P(X0,U,10) ;IMO
     174 .S:+LOC LOC=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO
     175 S $P(LST(IDX),U,19)=LOC ;IMO
     176 ;
     177 S ORIGVIEW=$S($G(TXTVW)=0:0,$G(TXTVW)=1:1,ORYD=-1:1,'ORYD:1,$P(X8,U)'<ORYD:0,1:1)
     178 K TXT D TEXT^ORQ12(.TXT,ID,255)                  ; optimize this later
     179 I $O(^OR(100,+IFN,2,0)) S LN=$O(TXT(0)),TXT(LN)="+"_TXT(LN)
     180 I $O(^OR(100,+IFN,8,"C","XX",0)) S LN=$O(TXT(0)),TXT(LN)="*"_TXT(LN)
     181 S LN=0 F  S LN=$O(TXT(LN)) Q:'LN  S IDX=IDX+1,LST(IDX)="t"_TXT(LN)
     182 I $O(^OR(100,+IFN,8,1,.2,0)) S IDX=IDX+1,LST(IDX)="|" D  ;PKI XMLText
     183 . S I=0 F  S I=$O(^OR(100,+IFN,8,1,.2,I)) Q:'I  S IDX=IDX+1,LST(IDX)="x"_^(I,0)
     184 Q
     185RSTRT() ; return start date from responses
     186 Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","START",0)),1))
     187RSTOP() ; return stop date from responses
     188 Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","STOP",0)),1))
     189GETTXT(LST,IFN)     ; get the text of an order
     190 I $L(IFN,";")=1 S IFN=IFN_";1"
     191 D TEXT^ORQ12(.LST,IFN,255)
     192 Q
     193XPND(AGRP) ; procedure
     194 ; Expand a display group (GROUPS must be defined outside of call)
     195 N I,CHLD
     196 S GROUPS(AGRP)=^ORD(100.98,AGRP,0),I=0
     197 F  S I=$O(^ORD(100.98,AGRP,1,I)) Q:'I  S CHLD=$P(^(I,0),U) D XPND(CHLD)
     198 Q
     199GETPKG(Y,IFN) ; get pkg for order
     200 N ORDERID,PKGID
     201 Q:+IFN<1
     202 S ORDERID=+IFN,Y=""
     203 S PKGID=$P(OR(100,ORDERID,0),U,14)
     204 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
     205 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR1.m

    r613 r623  
    1 ORWORR1 ; SLC/JLI - Utilities for Retrieve Orders for Broker ; 4/3/08 7:47am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242
    3         ;Called from ORWORR
    4 GET1    ;
    5         S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT")
    6         S I=.1 F  S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I  S IFN=^(I) D
    7         . I $G(ORRECIP)&&($G(FILTER)=12&&($$FLAGRULE(+IFN))) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q
    8         . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q
    9         . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17)
    10         . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID)
    11         . S ^TMP("ORR",$J,ORLIST,I)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME
    12         S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100
    13         S ^TMP("ORR",$J,ORLIST,.1)=TOT_U_TXTVW_U_$G(ORYD,0)
    14         S REF=$NA(^TMP("ORR",$J,ORLIST))
    15         Q
    16 GET2    ; For AUTO DC/Event Release Orders
    17         N JDND,JDIX,JDCNT,DCSPLIT
    18         S JDCNT=1,DCSPLIT=0
    19         S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT")
    20         F JDND="RL","DC" D
    21         . S I=.1 F  S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I  D
    22         . . I '$D(^TMP("ORR",$J,ORLIST,I,JDND)) Q
    23         . . S JDIX=0 F  S JDIX=$O(^TMP("ORR",$J,ORLIST,I,JDND,JDIX)) Q:'JDIX  S IFN=^(JDIX)  D
    24         . . . I 'DCSPLIT,(JDND="DC") D
    25         . . . . S ^TMP("ORRJD",$J,JDCNT)="DC START"
    26         . . . . S DCSPLIT=1,JDCNT=JDCNT+1,TOT=TOT+1
    27         . . . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) S TOT=TOT-1 Q
    28         . . . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17)
    29         . . . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID)
    30         . . . S ^TMP("ORRJD",$J,JDCNT)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME
    31         . . . S JDCNT=JDCNT+1
    32         S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100
    33         S ^TMP("ORRJD",$J,.1)=TOT_U_TXTVW_U_$G(ORYD,0)
    34         S REF=$NA(^TMP("ORRJD",$J))
    35         Q
    36 FLAGRULE(ORNUM,USR)     ;
    37         ;returns 0 if we should keep ORNUM in the list
    38         ;returns 1 if we should remove ORNUM from the list
    39         ;determines based on whether the user USR should see these flagged orders
    40         ; based on presence in file 100 NODE 8 FIELD 39 and
    41         ; based on whether the user should have gotten the flag due to provider recipients
    42         N ORI,ORRET,ORQUIT,I,LST,ORDFN
    43         I '$G(USR) S USR=DUZ
    44         S ORRET=1,ORQUIT=0
    45         S ORI=0 F  S ORI=$O(^OR(100,ORNUM,8,ORI)) Q:'ORI  D
    46         .I '$P($G(^OR(100,ORNUM,8,ORI,3)),U,6)&($P($G(^OR(100,ORNUM,8,ORI,3)),U,9)) S LST($P($G(^OR(100,ORNUM,8,ORI,3)),U,9))=""
    47         S ORDFN=+$P($G(^OR(100,ORNUM,0)),U,2)
    48         D START^ORBPRCHK(.LST,ORNUM,6,ORDFN)
    49         ;add ordering provider
    50         N ORDPROV
    51         S ORDPROV=$$ORDERER^ORQOR2(ORNUM)
    52         I $G(ORDPROV) S LST(ORDPROV)=""
    53         D ADDSURR(.LST)
    54         I $D(LST(USR)) S ORRET=0
    55         Q ORRET
    56 ADDSURR(LST)    ;TAKE LIST OF USERS AND ADD SURROGATES TO THE LIST
    57         N I
    58         S I=0 F  S I=$O(LST(I)) Q:'I  S LST($$CURRSURO^XQALSURO(I))=""
    59         Q
     1ORWORR1 ; SLC/JLI - Utilities for Retrieve Orders for Broker ;9/10/02 3PM [9/16/02 2:56pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997
     3 ;Called from ORWORR
     4GET1 ;
     5 S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT")
     6 S I=.1 F  S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I  S IFN=^(I) D
     7 . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q
     8 . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17)
     9 . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID)
     10 . S ^TMP("ORR",$J,ORLIST,I)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME
     11 S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100
     12 S ^TMP("ORR",$J,ORLIST,.1)=TOT_U_TXTVW_U_$G(ORYD,0)
     13 S REF=$NA(^TMP("ORR",$J,ORLIST))
     14 Q
     15GET2 ; For AUTO DC/Event Release Orders
     16 N JDND,JDIX,JDCNT,DCSPLIT
     17 S JDCNT=1,DCSPLIT=0
     18 S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT")
     19 F JDND="RL","DC" D
     20 . S I=.1 F  S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I  D
     21 . . I '$D(^TMP("ORR",$J,ORLIST,I,JDND)) Q
     22 . . S JDIX=0 F  S JDIX=$O(^TMP("ORR",$J,ORLIST,I,JDND,JDIX)) Q:'JDIX  S IFN=^(JDIX)  D
     23 . . . I 'DCSPLIT,(JDND="DC") D
     24 . . . . S ^TMP("ORRJD",$J,JDCNT)="DC START"
     25 . . . . S DCSPLIT=1,JDCNT=JDCNT+1,TOT=TOT+1
     26 . . . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) S TOT=TOT-1 Q
     27 . . . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17)
     28 . . . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID)
     29 . . . S ^TMP("ORRJD",$J,JDCNT)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME
     30 . . . S JDCNT=JDCNT+1
     31 S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100
     32 S ^TMP("ORRJD",$J,.1)=TOT_U_TXTVW_U_$G(ORYD,0)
     33 S REF=$NA(^TMP("ORRJD",$J))
     34 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m

    r613 r623  
    1 ORWPCE  ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;10/11/06  16:05
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 2950   LOOK^LEXA          ^TMP("LEXFND",$J)
    5         ; DBIA 1609   CONFIG^LEXSET      ^TMP("LEXSCH",$J)
    6         ; DBIA 1365   DSELECT^GMPLENFM   ^TMP("IB",$J)
    7         ; DBIA 3991   $$STATCHK^ICDAPIU
    8         ;
    9         Q
    10 VISIT(LST,CLINIC,ORDATE)        ; get list of visit types for clinic
    11         S:'+$G(ORDATE) ORDATE=DT
    12         D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE)
    13         Q
    14 PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods
    15         S:'+$G(ORDATE) ORDATE=DT
    16         D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE)
    17         N IDX,MOD,CODES,FIRST S IDX=0
    18         F  S IDX=$O(LST(IDX)) Q:'+IDX  D
    19         . I LST(IDX)="" K LST(IDX) Q
    20         . S MOD=0,CODES="",FIRST=1
    21         . F  S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="")  D
    22         . . I FIRST S FIRST=0
    23         . . E  S CODES=CODES_";"
    24         . . S CODES=CODES_LST(IDX,"MODIFIER",MOD)
    25         . K LST(IDX,"MODIFIER")
    26         . I 'FIRST S $P(LST(IDX),U,12)=CODES
    27         Q
    28 CPTMODS(LST,ORCPTCOD,ORDATE)    ;Return CPT Modifiers for a CPT Code
    29         N ORM,ORIDX,ORI,MODNAME
    30         S:'+$G(ORDATE) ORDATE=DT
    31         I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D
    32         . S ORIDX="",ORI=0
    33         . F  S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="")  D
    34         . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1)
    35         . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX
    36         Q
    37 GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier
    38         N ORDATA
    39         S:'+$G(ORDATE) ORDATE=DT
    40         S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1)
    41         I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2)
    42         Q
    43 DIAG(LST,CLINIC,ORDATE) ; get list of diagnoses for clinic
    44         S:'+$G(ORDATE) ORDATE=DT
    45         D GETLST^IBDF18A(CLINIC,"DG SELECT ICD-9 DIAGNOSIS CODES","LST",,,,ORDATE)
    46         Q
    47 IMM(LST,CLINIC) ;get list of immunizations for clinic
    48         D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST")
    49         Q
    50 SK(LST,CLINIC)  ;get list of skin test for clinic
    51         D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST")
    52         Q
    53 HF(LST,CLINIC)  ;get list of health factors for clinic
    54         D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST")
    55         Q
    56 PED(LST,CLINIC) ;get list of education topices for clinic
    57         D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST")
    58         Q
    59 TRT(LST,CLINIC) ;get list of treatments for clinic
    60         D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST")
    61         Q
    62 XAM(LST,CLINIC) ;get list of exams for clinic
    63         D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST")
    64         Q
    65 ACTPROB(GLST,DFN,ORDATE)        ;get list of patient's active problems
    66         K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
    67         S:'+$G(ORDATE) ORDATE=DT
    68         D DSELECT^GMPLENFM  ;DBIA 1365
    69         N ORPROB,ORPROBIX,ORPRCNT
    70         S ORPRCNT=0
    71         S ORPROBIX=0
    72         F  S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX  D  ;DBIA 1365
    73         . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)
    74         . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255)
    75         . I '$D(ORPROB(ORPROB)) D
    76         .. S ORPROB(ORPROB)=""
    77         .. S ORPRCNT=ORPRCNT+1
    78         .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB
    79         . E  K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)
    80         ; DBIA   10082     NAME: ICD DIAGNOSIS FILE
    81         N ORWINDEX,ORITEM
    82         S ORWINDEX=0
    83         F  S ORWINDEX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)) Q:'ORWINDEX  D:$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX),"^",1)]""
    84         . S ORITEM=^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)
    85         . I '+$$STATCHK^ICDAPIU($P(ORITEM,"^",3),ORDATE) S $P(ORITEM,"^",11)="#"  ;DBIA 3991
    86         . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)=ORITEM
    87         S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT
    88         S GLST="^TMP(""IB"","_$J_",""INTERFACES"",""GMP SELECT PATIENT ACTIVE PROBLEMS"")"
    89         Q
    90 SCSEL(VAL,DFN,ATM,LOC,VST)      ; return SC conditions that may be selected
    91         ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt;
    92         ;     MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt;SHADAllow^SHADDflt
    93         N ORX,S S S=";"
    94         D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX)
    95         S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV"))_S_$G(ORX("SHAD"))
    96         Q
    97 SCDIS(LST,DFN)  ; Return service connected % and rated disabilities
    98         N VAEL,VAERR,I,ILST,DIS,SC,X
    99         D ELIG^VADPT
    100         S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
    101         I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
    102         S I=0,ILST=1 F  S I=$O(^DPT(DFN,.372,I)) Q:'I  S X=^(I,0) D
    103         . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
    104         . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
    105         . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
    106         I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
    107         Q
    108 CPTREQD(VAL,IEN)        ; return 1 in VAL if note still needs a CPT code
    109         S VAL=+$P(^TIU(8925,IEN,0),U,11)
    110         Q
    111 NOTEVSTR(VAL,IEN)       ; return the VSTR^AUTHOR for a note
    112         N X0,X12,VISIT
    113         S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7)
    114         I +VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT) I 1
    115         E  S VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13)
    116         Q
    117 HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE)       ;Has visit or is stand alone
    118         N ORVISIT
    119         S ORY=-1
    120         I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3)
    121         I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC)
    122         I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT)
    123         Q
    124 DELETE(VAL,VSTR,DFN)    ; delete PCE info when deleting a note
    125         N VISIT,ORCOUNT
    126         N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
    127         I '$D(^TMP("ORWPCE",$J,VSTR)) S VAL=0 Q  ; no PCE data saved yet
    128         I $P(VSTR,";",3)="H" S VAL=0 Q           ; leave inpatient alone
    129         I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q    ; leave if no tiu entry point
    130         D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR)     ; Do not delete if another
    131         I ORCOUNT>0 S VAL=0 Q                    ; title points to visit
    132         S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H
    133         S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE"
    134         S ZTSYNC="ORW"_VSTR
    135         D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1
    136         Q
    137 SAVE(OK,PCELIST,NOTEIEN,ORLOC)  ; save PCE information
    138         N VSTR,GMPLUSER
    139         N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
    140         S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR)
    141         M ^TMP("ORWPCE",$J,VSTR)=PCELIST
    142         S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN)
    143         S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H
    144         S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE"
    145         S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")=""
    146         I VSTR'["E" S ZTSYNC="ORW"_VSTR
    147         S ZTSAVE("ORLOC")=""
    148         D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1
    149         Q
    150 LEX(LST,X,APP,ORDATE)     ; return list after lexicon lookup
    151         N LEX,ILST,I,IEN
    152         S:APP="CPT" APP="CHP" ; LEX PATCH 10
    153         S:'+$G(ORDATE) ORDATE=DT
    154         D CONFIG^LEXSET(APP,APP,ORDATE)  ;DBIA 1609
    155         I APP="CHP" D
    156         . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")
    157         . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))"  ;DBIA 1609
    158         . ; Set Applications Default Flag (Lexicon can not overwrite filter)
    159         . S ^TMP("LEXSCH",$J,"ADF",0)=1
    160         D LOOK^LEXA(X,APP,1,"",ORDATE)
    161         I '$D(LEX("LIST",1)) S LST(1)="-1^No matches found." Q
    162         S LST(1)=LEX("LIST",1),ILST=1
    163         S (I,IEN)=""
    164         F  S I=$O(^TMP("LEXFND",$J,I)) Q:I=""  D  ;DBIA 2950
    165         .F  S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN=""  D
    166         ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN)
    167         K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
    168         Q
    169 LEXCODE(VAL,IEN,APP,ORDATE)         ; return code for a lexicon entry
    170         S VAL=""
    171         S:'+$G(ORDATE) ORDATE=DT
    172         I APP="ICD" S VAL=$$ICDONE^LEXU(IEN,ORDATE)
    173         I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE) ; LEX PATCH 10
    174         I VAL="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE) ; LEX PATCH 10
    175         Q
    176 ADDRES  ; Add the ORW/PXAPI RESOURCE device
    177         N X
    178         S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions")
    179         Q
    180 GETSVC(NEWSVC,SVC,LOC,INP)      ; Returns the correct Service Connected Category
    181         N DSS,ORWSVC
    182         S DSS=$P($G(^SC(+LOC,0)),U,7)
    183         Q:'+DSS
    184         M ORWSVC=SVC
    185         S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225
    186         Q
     1ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;07/05/04
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215**;Dec 17, 1997
     3 ;
     4 ; DBIA 2950   LOOK^LEXA          ^TMP("LEXFND",$J)
     5 ; DBIA 1609   CONFIG^LEXSET      ^TMP("LEXSCH",$J)
     6 ; DBIA 1365   DSELECT^GMPLENFM   ^TMP("IB",$J)
     7 ; DBIA 3991   $$STATCHK^ICDAPIU
     8 ;
     9 Q
     10VISIT(LST,CLINIC,ORDATE) ; get list of visit types for clinic
     11 S:'+$G(ORDATE) ORDATE=DT
     12 D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE)
     13 Q
     14PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods
     15 S:'+$G(ORDATE) ORDATE=DT
     16 D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE)
     17 N IDX,MOD,CODES,FIRST S IDX=0
     18 F  S IDX=$O(LST(IDX)) Q:'+IDX  D
     19 . I LST(IDX)="" K LST(IDX) Q
     20 . S MOD=0,CODES="",FIRST=1
     21 . F  S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="")  D
     22 . . I FIRST S FIRST=0
     23 . . E  S CODES=CODES_";"
     24 . . S CODES=CODES_LST(IDX,"MODIFIER",MOD)
     25 . K LST(IDX,"MODIFIER")
     26 . I 'FIRST S $P(LST(IDX),U,12)=CODES
     27 Q
     28CPTMODS(LST,ORCPTCOD,ORDATE) ;Return CPT Modifiers for a CPT Code
     29 N ORM,ORIDX,ORI,MODNAME
     30 S:'+$G(ORDATE) ORDATE=DT
     31 I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D
     32 . S ORIDX="",ORI=0
     33 . F  S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="")  D
     34 . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1)
     35 . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX
     36 Q
     37GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier
     38 N ORDATA
     39 S:'+$G(ORDATE) ORDATE=DT
     40 S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1)
     41 I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2)
     42 Q
     43DIAG(LST,CLINIC,ORDATE) ; get list of diagnoses for clinic
     44 S:'+$G(ORDATE) ORDATE=DT
     45 D GETLST^IBDF18A(CLINIC,"DG SELECT ICD-9 DIAGNOSIS CODES","LST",,,,ORDATE)
     46 Q
     47IMM(LST,CLINIC) ;get list of immunizations for clinic
     48 D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST")
     49 Q
     50SK(LST,CLINIC) ;get list of skin test for clinic
     51 D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST")
     52 Q
     53HF(LST,CLINIC) ;get list of health factors for clinic
     54 D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST")
     55 Q
     56PED(LST,CLINIC) ;get list of education topices for clinic
     57 D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST")
     58 Q
     59TRT(LST,CLINIC) ;get list of treatments for clinic
     60 D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST")
     61 Q
     62XAM(LST,CLINIC) ;get list of exams for clinic
     63 D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST")
     64 Q
     65ACTPROB(GLST,DFN,ORDATE) ;get list of patient's active problems
     66 K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
     67 S:'+$G(ORDATE) ORDATE=DT
     68 D DSELECT^GMPLENFM  ;DBIA 1365
     69 N ORPROB,ORPROBIX,ORPRCNT
     70 S ORPRCNT=0
     71 S ORPROBIX=0
     72 F  S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX  D  ;DBIA 1365
     73 . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)
     74 . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255)
     75 . I '$D(ORPROB(ORPROB)) D
     76 .. S ORPROB(ORPROB)=""
     77 .. S ORPRCNT=ORPRCNT+1
     78 .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB
     79 . E  K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)
     80 ; DBIA   10082     NAME: ICD DIAGNOSIS FILE
     81 N ORWINDEX,ORITEM
     82 S ORWINDEX=0
     83 F  S ORWINDEX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)) Q:'ORWINDEX  D:$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX),"^",1)]""
     84 . S ORITEM=^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)
     85 . I '+$$STATCHK^ICDAPIU($P(ORITEM,"^",3),ORDATE) S $P(ORITEM,"^",11)="#"  ;DBIA 3991
     86 . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)=ORITEM
     87 S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT
     88 S GLST="^TMP(""IB"","_$J_",""INTERFACES"",""GMP SELECT PATIENT ACTIVE PROBLEMS"")"
     89 Q
     90SCSEL(VAL,DFN,ATM,LOC,VST) ; return SC conditions that may be selected
     91 ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt;
     92 ;     MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt
     93 N ORX,S S S=";"
     94 D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX)
     95 S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV"))
     96 Q
     97SCDIS(LST,DFN) ; Return service connected % and rated disabilities
     98 N VAEL,VAERR,I,ILST,DIS,SC,X
     99 D ELIG^VADPT
     100 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
     101 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
     102 S I=0,ILST=1 F  S I=$O(^DPT(DFN,.372,I)) Q:'I  S X=^(I,0) D
     103 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
     104 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
     105 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
     106 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
     107 Q
     108CPTREQD(VAL,IEN) ; return 1 in VAL if note still needs a CPT code
     109 S VAL=+$P(^TIU(8925,IEN,0),U,11)
     110 Q
     111NOTEVSTR(VAL,IEN) ; return the VSTR^AUTHOR for a note
     112 N X0,X12,VISIT
     113 S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7)
     114 I +VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT) I 1
     115 E  S VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13)
     116 Q
     117HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) ;Has visit or is stand alone
     118 N ORVISIT
     119 S ORY=-1
     120 I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3)
     121 I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC)
     122 I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT)
     123 Q
     124DELETE(VAL,VSTR,DFN) ; delete PCE info when deleting a note
     125 N VISIT,ORCOUNT
     126 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
     127 I '$D(^TMP("ORWPCE",$J,VSTR)) S VAL=0 Q  ; no PCE data saved yet
     128 I $P(VSTR,";",3)="H" S VAL=0 Q           ; leave inpatient alone
     129 I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q    ; leave if no tiu entry point
     130 D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR)     ; Do not delete if another
     131 I ORCOUNT>0 S VAL=0 Q                    ; title points to visit
     132 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H
     133 S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE"
     134 S ZTSYNC="ORW"_VSTR
     135 D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1
     136 Q
     137SAVE(OK,PCELIST,NOTEIEN,ORLOC) ; save PCE information
     138 N VSTR,GMPLUSER
     139 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
     140 S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR)
     141 M ^TMP("ORWPCE",$J,VSTR)=PCELIST
     142 S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN)
     143 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H
     144 S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE"
     145 S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")=""
     146 I VSTR'["E" S ZTSYNC="ORW"_VSTR
     147 S ZTSAVE("ORLOC")=""
     148 D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1
     149 Q
     150LEX(LST,X,APP,ORDATE)   ; return list after lexicon lookup
     151 N LEX,ILST,I,IEN
     152 S:APP="CPT" APP="CHP" ; LEX PATCH 10
     153 S:'+$G(ORDATE) ORDATE=DT
     154 D CONFIG^LEXSET(APP,APP,ORDATE)  ;DBIA 1609
     155 I APP="CHP" D
     156 . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")
     157 . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))"  ;DBIA 1609
     158 . ; Set Applications Default Flag (Lexicon can not overwrite filter)
     159 . S ^TMP("LEXSCH",$J,"ADF",0)=1
     160 D LOOK^LEXA(X,APP,1,"",ORDATE)
     161 I '$D(LEX("LIST",1)) S LST(1)="-1^No matches found." Q
     162 S LST(1)=LEX("LIST",1),ILST=1
     163 S (I,IEN)=""
     164 F  S I=$O(^TMP("LEXFND",$J,I)) Q:I=""  D  ;DBIA 2950
     165 .F  S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN=""  D
     166 ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN)
     167 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
     168 Q
     169LEXCODE(VAL,IEN,APP,ORDATE)     ; return code for a lexicon entry
     170 S VAL=""
     171 S:'+$G(ORDATE) ORDATE=DT
     172 I APP="ICD" S VAL=$$ICDONE^LEXU(IEN,ORDATE)
     173 I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE) ; LEX PATCH 10
     174 I VAL="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE) ; LEX PATCH 10
     175 Q
     176ADDRES ; Add the ORW/PXAPI RESOURCE device
     177 N X
     178 S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions")
     179 Q
     180GETSVC(NEWSVC,SVC,LOC,INP) ; Returns the correct Service Connected Category
     181 N DSS,ORWSVC
     182 S DSS=$P($G(^SC(+LOC,0)),U,7)
     183 Q:'+DSS
     184 M ORWSVC=SVC
     185 S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225
     186 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE1.m

    r613 r623  
    1 ORWPCE1 ;SLC/KCM - PCE Calls from CPRS GUI; 10/26/04 ;4/9/08  07:44
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,187,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 1365   DSELECT^GMPLENFM   ^TMP("IB",$J)
    5         ;
    6 GETVSIT(VSTR,DFN)       ; lookup a visit
    7         N PKG,SRC,ORPXAPI,OK,ORVISIT
    8         S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0))
    9         S SRC="TEXT INTEGRATION UTILITIES"
    10         S ORPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2)
    11         S ORPXAPI("ENCOUNTER",1,"PATIENT")=DFN
    12         S ORPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR
    13         S ORPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3)
    14         S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
    15         S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORVISIT)
    16         Q ORVISIT
    17 DQDEL   ; background call to DATA2PCE and DELVFILE
    18         N VISIT,VAL
    19         I $D(ZTQUEUED) S ZTREQ="@"
    20         S VISIT=$$GETVSIT(VSTR,DFN)
    21         S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES")
    22         S ZTSTAT=0  ; clear sync flag
    23         Q
    24 DQSAVE  ; Background Call to DATA2PCE
    25         N PKG,SRC,TYP,CODE,IEN,OK,I,X,ORPXAPI,ORPXDEL
    26         N CAT,NARR,ROOT,ROOT2,ORAVST
    27         N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS
    28         N COM,COMMENT,COMMENTS
    29         N DFN,PROBLEMS,PXAPREDT,ORCPTDEL
    30         I $D(ZTQUEUED) S ZTREQ="@"
    31         S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0))
    32         S SRC="TEXT INTEGRATION UTILITIES"
    33         S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0
    34         S I="" F  S I=$O(PCELIST(I)) Q:'I  S X=PCELIST(I) D
    35         . S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4)
    36         . I $E(TYP,1,3)="PRV" D  Q
    37         . . Q:'$L(CODE)
    38         . . S PRV=PRV+1
    39         . . S ROOT="ORPXAPI(""PROVIDER"","_PRV_")"
    40         . . S ROOT2="ORPXDEL(""PROVIDER"","_PRV_")"
    41         . . I $E(TYP,4)'="-" D
    42         . . . S @ROOT@("NAME")=CODE
    43         . . . S @ROOT@("PRIMARY")=$P(X,U,6)
    44         . . S @ROOT2@("NAME")=CODE
    45         . . S @ROOT2@("DELETE")=1
    46         . . S PXAPREDT=1 ;Allow edit of primary flag
    47         . I TYP="VST" D  Q
    48         . . S ROOT="ORPXAPI(""ENCOUNTER"",1)"
    49         . . I CODE="DT" S @ROOT@("ENC D/T")=$P(X,U,3) Q
    50         . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q
    51         . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q
    52         . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q
    53         . . ;prevents checkout!
    54         . . I CODE="VC" S @ROOT@("SERVICE CATEGORY")=$P(X,U,3) Q
    55         . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q
    56         . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q
    57         . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q
    58         . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q
    59         . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q
    60         . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q
    61         . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q
    62         . . I CODE="SHD" S @ROOT@("SHAD")=$P(X,U,3) Q
    63         . . I CODE="OL" D  Q
    64         . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3)
    65         . . . E  I $P(X,U,4)'="",$P(X,U,4)'="0" D
    66         . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4)
    67         . . . . E  S @ROOT@("COMMENT")="OUTSIDE LOCATION:  "_$P(X,U,4)
    68         . I $E(TYP,1,3)="CPT" D  Q
    69         . . Q:'$L(CODE)
    70         . . S CPT=CPT+1,ROOT="ORPXAPI(""PROCEDURE"","_CPT_")"
    71         . . S IEN=+$O(^ICPT("B",CODE,0))
    72         . . S @ROOT@("PROCEDURE")=IEN
    73         . . I +$P(X,U,9) D
    74         . . . S MODS=$P(X,U,9),MODCNT=+MODS
    75         . . . F MODIDX=1:1:MODCNT D
    76         . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/")
    77         . . . . S @ROOT@("MODIFIERS",MOD)=""
    78         . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
    79         . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
    80         . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
    81         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    82         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT
    83         . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,ORCPTDEL=CPT
    84         . I $E(TYP,1,3)="POV" D  Q
    85         . . Q:'$L(CODE)
    86         . . S ICD=ICD+1,ROOT="ORPXAPI(""DX/PL"","_ICD_")"
    87         . . S IEN=+$O(^ICD9("AB",CODE_" ",0))
    88         . . S @ROOT@("DIAGNOSIS")=IEN
    89         . . S @ROOT@("PRIMARY")=$P(X,U,5)
    90         . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
    91         . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
    92         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    93         . . I $L($P(X,U,7)),$P(X,U,7)=1 S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE
    94         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="DX/PL^"_ICD
    95         . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
    96         . I $E(TYP,1,3)="IMM" D  Q
    97         . . Q:'$L(CODE)
    98         . . S IMM=IMM+1,ROOT="ORPXAPI(""IMMUNIZATION"","_IMM_")"
    99         . . S @ROOT@("IMMUN")=CODE
    100         . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5)
    101         . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7)
    102         . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8)
    103         . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9)
    104         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    105         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM
    106         . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
    107         . I $E(TYP,1,2)="SK" D  Q
    108         . . Q:'$L(CODE)
    109         . . S SK=SK+1,ROOT="ORPXAPI(""SKIN TEST"","_SK_")"
    110         . . S @ROOT@("TEST")=CODE
    111         . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
    112         . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7)
    113         . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8)
    114         . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9)
    115         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    116         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK
    117         . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
    118         . I $E(TYP,1,3)="PED" D  Q
    119         . . Q:'$L(CODE)
    120         . . S PED=PED+1,ROOT="ORPXAPI(""PATIENT ED"","_PED_")"
    121         . . S @ROOT@("TOPIC")=CODE
    122         . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5)
    123         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    124         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED
    125         . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
    126         . I $E(TYP,1,2)="HF" D  Q
    127         . . Q:'$L(CODE)
    128         . . S HF=HF+1,ROOT="ORPXAPI(""HEALTH FACTOR"","_HF_")"
    129         . . S @ROOT@("HEALTH FACTOR")=CODE
    130         . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5)
    131         . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(ORPXAPI("PROVIDER",1,"NAME"))
    132         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    133         . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1)
    134         . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2)
    135         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF
    136         . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
    137         . I $E(TYP,1,3)="XAM" D  Q
    138         . . Q:'$L(CODE)
    139         . . S XAM=XAM+1,ROOT="ORPXAPI(""EXAM"","_XAM_")"
    140         . . S @ROOT@("EXAM")=CODE
    141         . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
    142         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    143         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM
    144         . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
    145         . I $E(TYP,1,3)="TRT" D  Q
    146         . . Q:'$L(CODE)
    147         . . S TRT=TRT+1,ROOT="ORPXAPI(""TREATMENT"","_TRT_")"
    148         . . S @ROOT@("IMMUN")=CODE
    149         . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
    150         . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
    151         . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
    152         . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
    153         . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT
    154         . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0
    155         . I $E(TYP,1,3)="COM" D  Q
    156         . . Q:'$L(CODE)
    157         . . Q:'$L(CAT)
    158         . . S COMMENTS(CODE)=$P(X,U,3,999)
    159         ;Store the comments
    160         S COM=""
    161         F  S COM=$O(COMMENT(COM)) Q:COM=""  S:$D(COMMENTS(COM)) ORPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
    162         ;
    163         ;Remove any problems to add that the patient already has as active problems
    164         I $D(PROBLEMS),$D(DFN) D
    165         . N ORWPROB,ORPROBIX
    166         . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
    167         . D DSELECT^GMPLENFM  ;DBIA 1365
    168         . S ORPROBIX=0
    169         . F  S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX  D  ;DBIA 1365
    170         .. S ORWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)
    171         .. S ORWPROB($S($E(ORWPROB,1)="$":$E(ORWPROB,2,255),1:ORWPROB))=""
    172         . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
    173         . Q:'$D(ORWPROB)
    174         . S ORPROBIX=""
    175         . F  S ORPROBIX=$O(PROBLEMS(ORPROBIX)) Q:'ORPROBIX  D
    176         .. S:$D(ORWPROB(PROBLEMS(ORPROBIX))) ORPXAPI("DX/PL",ORPROBIX,"PL ADD")=0
    177         ;
    178         I $$MDS(.ORPXAPI,$G(ORLOC)) S ORPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=$$NOW^XLFDT
    179         S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
    180 DATA2PCE        ;
    181         I $G(PXAPREDT)!($G(ORCPTDEL)) D
    182         . M ORPXDEL("ENCOUNTER")=ORPXAPI("ENCOUNTER")
    183         . I $G(ORCPTDEL) M ORPXDEL("PROCEDURE",ORCPTDEL)=ORPXAPI("PROCEDURE",ORCPTDEL)
    184         . S OK=$$DATA2PCE^PXAPI("ORPXDEL",PKG,SRC,.ORAVST)
    185         S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORAVST)
    186         I OK>0,+NOTEIEN,+ORAVST D  ; NOTEIEN only set on inpatient encounters
    187         .N OROK,ORX
    188         .S ORX(1207)=ORAVST
    189         .D FILE^TIUSRVP(.OROK,NOTEIEN,.ORX,1)
    190         S ZTSTAT=0  ; clear sync flag
    191         Q
    192         ;
    193 MDS(X,ORLOC)    ; return TRUE if checkout is needed
    194         I $$CHKOUT^ORWPCE2(ORLOC) Q 1
    195         N I,ORAUTO,OROK
    196         S (OROK,I)=0
    197         F  S I=$O(X("DX/PL",I)) Q:'I  D  Q:OROK
    198         . I $G(X("DX/PL",I,"DIAGNOSIS")) S OROK=1
    199         I 'OROK D
    200         .S I=0 F  S I=$O(X("PROCEDURE",I)) Q:'I  D  Q:OROK
    201         .. I $G(X("PROCEDURE",I,"PROCEDURE")) S OROK=1
    202         I $D(X("PROVIDER",1,"NAME")) S OROK=1
    203         Q OROK
    204 NONCOUNT(ORY,ORLOC)     ;  Is the location a non-count clinic? (DBIA #964)
    205         Q:'ORLOC
    206         S ORY=$S($P($G(^SC(ORLOC,0)),U,17)="Y":1,1:0)
    207         Q
     1ORWPCE1 ;SLC/KCM - PCE Calls from CPRS GUI; 10/26/04
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,187,190,215**;Dec 17, 1997
     3 ;
     4 ; DBIA 1365   DSELECT^GMPLENFM   ^TMP("IB",$J)
     5 ;
     6GETVSIT(VSTR,DFN) ; lookup a visit
     7 N PKG,SRC,ORPXAPI,OK,ORVISIT
     8 S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0))
     9 S SRC="TEXT INTEGRATION UTILITIES"
     10 S ORPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2)
     11 S ORPXAPI("ENCOUNTER",1,"PATIENT")=DFN
     12 S ORPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR
     13 S ORPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3)
     14 S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
     15 S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORVISIT)
     16 Q ORVISIT
     17DQDEL ; background call to DATA2PCE and DELVFILE
     18 N VISIT,VAL
     19 I $D(ZTQUEUED) S ZTREQ="@"
     20 S VISIT=$$GETVSIT(VSTR,DFN)
     21 S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES")
     22 S ZTSTAT=0  ; clear sync flag
     23 Q
     24DQSAVE ; Background Call to DATA2PCE
     25 N PKG,SRC,TYP,CODE,IEN,OK,I,X,ORPXAPI,ORPXDEL
     26 N CAT,NARR,ROOT,ROOT2,ORAVST
     27 N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS
     28 N COM,COMMENT,COMMENTS
     29 N DFN,PROBLEMS,PXAPREDT,ORCPTDEL
     30 I $D(ZTQUEUED) S ZTREQ="@"
     31 S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0))
     32 S SRC="TEXT INTEGRATION UTILITIES"
     33 S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0
     34 S I="" F  S I=$O(PCELIST(I)) Q:'I  S X=PCELIST(I) D
     35 . S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4)
     36 . I $E(TYP,1,3)="PRV" D  Q
     37 . . Q:'$L(CODE)
     38 . . S PRV=PRV+1
     39 . . S ROOT="ORPXAPI(""PROVIDER"","_PRV_")"
     40 . . S ROOT2="ORPXDEL(""PROVIDER"","_PRV_")"
     41 . . I $E(TYP,4)'="-" D
     42 . . . S @ROOT@("NAME")=CODE
     43 . . . S @ROOT@("PRIMARY")=$P(X,U,6)
     44 . . S @ROOT2@("NAME")=CODE
     45 . . S @ROOT2@("DELETE")=1
     46 . . S PXAPREDT=1 ;Allow edit of primary flag
     47 . I TYP="VST" D  Q
     48 . . S ROOT="ORPXAPI(""ENCOUNTER"",1)"
     49 . . I CODE="DT" S @ROOT@("ENC D/T")=$P(X,U,3) Q
     50 . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q
     51 . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q
     52 . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q
     53 . . ;prevents checkout!
     54 . . I CODE="VC" S @ROOT@("SERVICE CATEGORY")=$P(X,U,3) Q
     55 . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q
     56 . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q
     57 . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q
     58 . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q
     59 . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q
     60 . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q
     61 . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q
     62 . . I CODE="OL" D  Q
     63 . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3)
     64 . . . E  I $P(X,U,4)'="",$P(X,U,4)'="0" D
     65 . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4)
     66 . . . . E  S @ROOT@("COMMENT")="OUTSIDE LOCATION:  "_$P(X,U,4)
     67 . I $E(TYP,1,3)="CPT" D  Q
     68 . . Q:'$L(CODE)
     69 . . S CPT=CPT+1,ROOT="ORPXAPI(""PROCEDURE"","_CPT_")"
     70 . . S IEN=+$O(^ICPT("B",CODE,0))
     71 . . S @ROOT@("PROCEDURE")=IEN
     72 . . I +$P(X,U,9) D
     73 . . . S MODS=$P(X,U,9),MODCNT=+MODS
     74 . . . F MODIDX=1:1:MODCNT D
     75 . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/")
     76 . . . . S @ROOT@("MODIFIERS",MOD)=""
     77 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
     78 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
     79 . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
     80 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     81 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT
     82 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,ORCPTDEL=CPT
     83 . I $E(TYP,1,3)="POV" D  Q
     84 . . Q:'$L(CODE)
     85 . . S ICD=ICD+1,ROOT="ORPXAPI(""DX/PL"","_ICD_")"
     86 . . S IEN=+$O(^ICD9("AB",CODE_" ",0))
     87 . . S @ROOT@("DIAGNOSIS")=IEN
     88 . . S @ROOT@("PRIMARY")=$P(X,U,5)
     89 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
     90 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
     91 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     92 . . I $L($P(X,U,7)),$P(X,U,7)=1 S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE
     93 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="DX/PL^"_ICD
     94 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
     95 . I $E(TYP,1,3)="IMM" D  Q
     96 . . Q:'$L(CODE)
     97 . . S IMM=IMM+1,ROOT="ORPXAPI(""IMMUNIZATION"","_IMM_")"
     98 . . S @ROOT@("IMMUN")=CODE
     99 . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5)
     100 . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7)
     101 . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8)
     102 . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9)
     103 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     104 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM
     105 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
     106 . I $E(TYP,1,2)="SK" D  Q
     107 . . Q:'$L(CODE)
     108 . . S SK=SK+1,ROOT="ORPXAPI(""SKIN TEST"","_SK_")"
     109 . . S @ROOT@("TEST")=CODE
     110 . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
     111 . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7)
     112 . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8)
     113 . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9)
     114 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     115 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK
     116 . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
     117 . I $E(TYP,1,3)="PED" D  Q
     118 . . Q:'$L(CODE)
     119 . . S PED=PED+1,ROOT="ORPXAPI(""PATIENT ED"","_PED_")"
     120 . . S @ROOT@("TOPIC")=CODE
     121 . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5)
     122 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     123 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED
     124 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
     125 . I $E(TYP,1,2)="HF" D  Q
     126 . . Q:'$L(CODE)
     127 . . S HF=HF+1,ROOT="ORPXAPI(""HEALTH FACTOR"","_HF_")"
     128 . . S @ROOT@("HEALTH FACTOR")=CODE
     129 . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5)
     130 . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(ORPXAPI("PROVIDER",1,"NAME"))
     131 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     132 . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1)
     133 . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2)
     134 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF
     135 . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
     136 . I $E(TYP,1,3)="XAM" D  Q
     137 . . Q:'$L(CODE)
     138 . . S XAM=XAM+1,ROOT="ORPXAPI(""EXAM"","_XAM_")"
     139 . . S @ROOT@("EXAM")=CODE
     140 . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
     141 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     142 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM
     143 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
     144 . I $E(TYP,1,3)="TRT" D  Q
     145 . . Q:'$L(CODE)
     146 . . S TRT=TRT+1,ROOT="ORPXAPI(""TREATMENT"","_TRT_")"
     147 . . S @ROOT@("IMMUN")=CODE
     148 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
     149 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
     150 . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
     151 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
     152 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT
     153 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0
     154 . I $E(TYP,1,3)="COM" D  Q
     155 . . Q:'$L(CODE)
     156 . . Q:'$L(CAT)
     157 . . S COMMENTS(CODE)=$P(X,U,3,999)
     158 ;Store the comments
     159 S COM=""
     160 F  S COM=$O(COMMENT(COM)) Q:COM=""  S:$D(COMMENTS(COM)) ORPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
     161 ;
     162 ;Remove any problems to add that the patient already has as active problems
     163 I $D(PROBLEMS),$D(DFN) D
     164 . N ORWPROB,ORPROBIX
     165 . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
     166 . D DSELECT^GMPLENFM  ;DBIA 1365
     167 . S ORPROBIX=0
     168 . F  S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX  D  ;DBIA 1365
     169 .. S ORWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)
     170 .. S ORWPROB($S($E(ORWPROB,1)="$":$E(ORWPROB,2,255),1:ORWPROB))=""
     171 . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
     172 . Q:'$D(ORWPROB)
     173 . S ORPROBIX=""
     174 . F  S ORPROBIX=$O(PROBLEMS(ORPROBIX)) Q:'ORPROBIX  D
     175 .. S:$D(ORWPROB(PROBLEMS(ORPROBIX))) ORPXAPI("DX/PL",ORPROBIX,"PL ADD")=0
     176 ;
     177 I $$MDS(.ORPXAPI,$G(ORLOC)) S ORPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=$$NOW^XLFDT
     178 S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
     179DATA2PCE ;
     180 I $G(PXAPREDT)!($G(ORCPTDEL)) D
     181 . M ORPXDEL("ENCOUNTER")=ORPXAPI("ENCOUNTER")
     182 . I $G(ORCPTDEL) M ORPXDEL("PROCEDURE",ORCPTDEL)=ORPXAPI("PROCEDURE",ORCPTDEL)
     183 . S OK=$$DATA2PCE^PXAPI("ORPXDEL",PKG,SRC,.ORAVST)
     184 S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORAVST)
     185 I OK>0,+NOTEIEN,+ORAVST D  ; NOTEIEN only set on inpatient encounters
     186 .N OROK,ORX
     187 .S ORX(1207)=ORAVST
     188 .D FILE^TIUSRVP(.OROK,NOTEIEN,.ORX,1)
     189 S ZTSTAT=0  ; clear sync flag
     190 Q
     191 ;
     192MDS(X,ORLOC) ; return TRUE if checkout is needed
     193 I $$CHKOUT^ORWPCE2(ORLOC) Q 1
     194 N I,ORAUTO,OROK
     195 S (OROK,I)=0
     196 F  S I=$O(X("DX/PL",I)) Q:'I  D  Q:OROK
     197 . I $G(X("DX/PL",I,"DIAGNOSIS")) S OROK=1
     198 I 'OROK D
     199 .S I=0 F  S I=$O(X("PROCEDURE",I)) Q:'I  D  Q:OROK
     200 .. I $G(X("PROCEDURE",I,"PROCEDURE")) S OROK=1
     201 I $D(X("PROVIDER",1,"NAME")) S OROK=1
     202 Q OROK
     203NONCOUNT(ORY,ORLOC) ;  Is the location a non-count clinic? (DBIA #964)
     204 Q:'ORLOC
     205 S ORY=$S($P($G(^SC(ORLOC,0)),U,17)="Y":1,1:0)
     206 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE2.m

    r613 r623  
    1 ORWPCE2 ; ISL/JM/RV - wrap calls to PCE ;04/06/2006
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,173,195,243**;Dec 17, 1997;Build 242
    3 GETSET(ORWLST,ORWFILE,ORWFIELD,ORWNULL) ;gets set of codes
    4         ; ORWLST(n)=code^text for code
    5         N ORWPCE,ORWPCEL,ORWPCEC,ORWPCELO,ORWPCEHI,ORWPCECD,ORWPCET
    6         S ORWPCELO="abcdefghijklmnopqrstuvwxyz"
    7         S ORWPCEHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    8         D FIELD^DID(ORWFILE,ORWFIELD,"","POINTER","ORWPCE","ORWPCE")
    9         S ORWPCEL=$L(ORWPCE("POINTER"),";")-1
    10         F ORWPCEC=1:1:ORWPCEL D
    11         . S ORWPCECD=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",1)
    12         . S ORWPCET=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",2)
    13         . S ORWLST(ORWPCEC)=ORWPCECD_"^"_$E(ORWPCET)_$TR($E(ORWPCET,2,99),ORWPCEHI,ORWPCELO)
    14         S:$G(ORWNULL) ORWLST(0)="@^(None selected)"
    15         Q
    16         ;
    17 IMMTYPE(ORWLST,ORDT)    ;get the list of active immunizations
    18         N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
    19         S:'$G(ORDT) ORDT=DT
    20         F  S BINDEX=$O(^AUTTIMM("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  D
    21         . I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    22         . ;I $D(^AUTTIMM(IEN,0))#2,+$$SCREEN^XTID(9999999.14,,IEN,ORDT)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    23         Q
    24         ;
    25 SKTYPE(ORWLST,ORDT)     ;get the list of active skin test
    26         N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
    27         S:'$G(ORDT) ORDT=DT
    28         F  S BINDEX=$O(^AUTTSK("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  D
    29         . I $D(^AUTTSK(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    30         . ;I $D(^AUTTSK(IEN,0))#2,+$$SCREEN^XTID(9999999.28,,IEN,ORDT)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    31         Q
    32         ;
    33 EDTTYPE(ORWLST) ;get the list of active education topics
    34         N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
    35         F  S BINDEX=$O(^AUTTEDT("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTEDT(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    36         Q
    37         ;
    38 HFTYPE(ORWLST,ADDCATS)  ;get the list of active  health factors
    39         N IEN,CNT,BINDEX,REC
    40         S (IEN,CNT,BINDEX)=0,ADDCATS=+$G(ADDCATS)
    41         F  S BINDEX=$O(^AUTTHF("B",BINDEX)) Q:BINDEX']""  D
    42         .F  S IEN=$O(^AUTTHF("B",BINDEX,IEN)) Q:'+IEN  D
    43         ..S REC=$G(^AUTTHF(IEN,0))
    44         ..I +$P(REC,U,11) S REC=""
    45         ..I 'ADDCATS,$P(REC,U,10)="C" S REC=""
    46         ..I REC'="" D
    47         ...S CNT=CNT+1,ORWLST(CNT)=IEN_U_$P(REC,U)
    48         ...I ADDCATS S ORWLST(CNT)=ORWLST(CNT)_U_$P(REC,U,10)_U_$P(REC,U,3)
    49         Q
    50         ;
    51 EXAMTYPE(ORWLST)        ;get the list of active exams
    52         N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
    53         F  S BINDEX=$O(^AUTTEXAM("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTEXAM(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    54         Q
    55         ;
    56 TRTTYPE(ORWLST) ;get the list of active treatments
    57         N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
    58         F  S BINDEX=$O(^AUTTTRT("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTTRT(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
    59         Q
    60         ;
    61 ACTIVPRV(ORRETURN,ORWPROV,ORWDT)        ;get if provider is active or not
    62         S ORRETURN=$$ACTIVPRV^PXAPI(ORWPROV,ORWDT)
    63         Q
    64 GETVISIT(VISIT,IEN,DFN,VSITSTR) ;Get the visit IEN
    65         I +$G(IEN)<1 D  I 1
    66         .S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";"))
    67         E  S VISIT=$P(^TIU(8925,IEN,0),U,3)
    68         Q
    69 GAFOK(ORY)      ; Returns true if all supporting MH GAF Code exists
    70         S ORY=0
    71         I $T(GAFHX^YSGAFAPI)'="",$T(ENT^YSGAFAP1)'="" S ORY=1
    72         Q
    73 MHCLINIC(ORY,ORIEN)         ; See if this is a mental health clinic
    74         I $T(MHCLIN^SDUTL2)="" S ORY=1
    75         E  S ORY=$$MHCLIN^SDUTL2(ORIEN)
    76         Q
    77 LOADGAF(ORY,ORINPUT)    ; Retrieve GAF scores
    78         D GAFHX^YSGAFAPI(.ORY,.ORINPUT)
    79         Q
    80 SAVEGAF(ORY,ORINPUT)    ; Save new GAF score
    81         N ORDATA
    82         D ENT^YSGAFAP1(.ORDATA,.ORINPUT)
    83         S ORY=($G(ORDATA(1))="[DATA]")
    84         Q
    85 FORCE(ORY,USER,LOC)     ; Retrieve FORCE GUI PCE Entry for a given User/Location
    86         N SRV,ORTMP,ORERR
    87         S USER=$G(USER,DUZ)
    88         S SRV=$P($G(^VA(200,USER,5)),U)
    89         D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE FORCE PCE ENTRY","Q",.ORERR)
    90         S ORY=+$P($G(ORTMP(1)),U,2)
    91         Q
    92 HASCPT(ORY,ORLIST)             ; Returns true if there are any mapped CPT Codes
    93         N IEN,IDX,FOUND
    94         S IDX=0
    95         F  S IDX=$O(ORLIST(IDX)) Q:'+IDX  D
    96         . S FOUND=0
    97         . S IEN=$$FIND1^DIC(811.1,"","QX",ORLIST(IDX))
    98         . I +IEN S FOUND=+$$GET1^DIQ(811.1,IEN,.05,"I")
    99         . S ORY(IDX)=ORLIST(IDX)_"="_FOUND
    100         Q
    101 ASKPCE(ORY,USER,LOC)    ; Returns ORWPCE ASK ENCOUNTER UPDATE parameter value
    102         N SRV,ORTMP,ORERR
    103         S USER=$G(USER,DUZ)
    104         S SRV=$P($G(^VA(200,USER,5)),U)
    105         D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE ASK ENCOUNTER UPDATE","Q",.ORERR)
    106         S ORY=+$P($G(ORTMP(1)),U,2)
    107         Q
    108 GAFURL(URL)     ;Returns the MH GAF Web Page URL
    109         S URL=""
    110         I $T(GAFURL^YTAPI5)'="" D
    111         .N ORY
    112         .D GAFURL^YTAPI5(.ORY)
    113         .I $G(ORY(1))="[DATA]" S URL=$G(ORY(2))
    114         Q
    115 MHTESTOK(ORY)   ; Returns True if all supporting MH Test APIs exist
    116         D GAFOK(.ORY)
    117         I +ORY,+$G(DUZ),$T(SAVEIT^YTAPI1)'="",$T(PREVIEW^YTAPI4)'="",$T(SHOWALL^YTAPI3)'="",$T(LISTONE^YTAPI)'="",$T(MHS^PXRMRPCC)'="",$T(MHR^PXRMRPCC)'="",$T(MH^PXRMRPCC)'="" D
    118         . N SRV
    119         . S SRV=$P($G(^VA(200,DUZ,5)),U)
    120         . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM MENTAL HEALTH ACTIVE",1,"Q")
    121         . I +ORY S ORY=1
    122         Q
    123 MHATHRZD(ORY,TEST,USER) ;Indicates that user can score test
    124         N ORYS,ORANS
    125         I $T(PRIVL^YTAPI5)="" S ORY=1 Q
    126         S ORY=0
    127         S ORYS("CODE")=TEST
    128         S ORYS("STAFF")=USER
    129         D PRIVL^YTAPI5(.ORANS,.ORYS)
    130         I $G(ORANS(1))="[DATA]" S ORY=+$P($G(ORANS(2)),U,1)
    131         Q
    132 ANYTIME(ORY)    ;Returns status of the ORWPCE ANYTIME ENCOUNTERS parameter
    133         N SRV
    134         S SRV=$P($G(^VA(200,DUZ,5)),U)
    135         S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE ANYTIME ENCOUNTERS",1,"Q")
    136         I +ORY S ORY=1
    137         Q
    138 AUTOVSIT(ORY,LOC)       ; Returns TRUE if automatic selection of Visit Type
    139         N SRV
    140         S SRV=$P($G(^VA(200,DUZ,5)),U)
    141         S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO VISIT TYPE",1,"Q")
    142         I +ORY S ORY=1
    143         S ORY='ORY
    144         Q
    145 DOCHKOUT(ORY,LOC)       ; Returns TRUE if automatic selection of Visit Type
    146         N SRV
    147         S SRV=$P($G(^VA(200,DUZ,5)),U)
    148         S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO CHECKOUT",1,"Q")
    149         I +ORY S ORY=1
    150         S ORY='ORY
    151         Q
    152 CHKOUT(LOC)     ; Returns TRUE if automatic selection of Visit Type
    153         N ORY
    154         D DOCHKOUT(.ORY,LOC)
    155         Q ORY
    156 EXCLUDED(ORY,LOC,TYPE)  ; Returns list of excluded PCE data elements
    157         N SRV,PARAM
    158         S PARAM=$S(TYPE=1:"IMMUNIZATIONS",TYPE=2:"SKIN TESTS",TYPE=3:"PATIENT ED",TYPE=4:"HEALTH FACTORS",TYPE=5:"EXAMS",1:"")
    159         Q:PARAM=""
    160         S SRV=$P($G(^VA(200,DUZ,5)),U)
    161         S PARAM="ORWPCE EXCLUDE "_PARAM
    162         D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG",PARAM,"Q",.ORERR)
    163         Q
    164 ISCLINIC(ORY,ORLOC)     ; Returns TRUE if location is a clinic
    165         N ORTYP
    166         S ORY=0
    167         S ORTYP=$$GET1^DIQ(44,+ORLOC,2,"I")
    168         I (ORTYP="C")!(ORTYP="M") S ORY=1
    169         Q
    170 HNCOK(ORY)      ; Returns true if Head and/or Neck Cancer is enabled
    171         S ORY=0
    172         I $$PATCH^XPDUTL("DG*5.3*397"),$$PATCH^XPDUTL("SD*5.3*244"),$$PATCH^XPDUTL("PX*1.0*111"),$$PATCH^XPDUTL("IVM*2.0*46") S ORY=1
    173         Q
    174         ;
    175 CODACTIV(ORY,ORCODE,ORAPP,ORDATE)             ; Is code active on the given date?
    176         ; Remote procedure:  ORWPCE ACTIVE CODE
    177         ; ORCODE = ICD or CPT code to be checked
    178         ; ORAPP  = "ICD" or "CHP"
    179         ; ORDATE = Date to be checked (defaults to current date)
    180         S:'+$G(ORDATE) ORDATE=DT
    181         S ORY=1
    182         I ORAPP="ICD" D
    183         . S ORY=+$$STATCHK^ICDAPIU(ORCODE,ORDATE)
    184         E  I ORAPP="CHP" D
    185         . S ORY=+$$STATCHK^ICPTAPIU(ORCODE,ORDATE)
    186         Q
    187 ICDACTIV(ORCODE,ORDATE) ; Check for active ICD code
    188         D CODACTIV(.ORY,ORCODE,"ICD",$G(ORDATE))
    189         Q +ORY
    190 CPTACTIV(ORCODE,ORDATE) ; Check for active CPT code
    191         D CODACTIV(.ORY,ORCODE,"CHP",$G(ORDATE))
    192         Q +ORY
    193 CXNOSHOW(ORY,ORDOCIEN)  ; Should workload requirement be skipped for this note's visit?
    194         ; RETURN VALUE:  0=SKIP ALL GUI WORKLOAD REQUIREMENTS
    195         ;                1=CONTINUE WITH OTHER GUI WORKLOAD LOGIC
    196         N ORTIU
    197         D DOCPARM^TIUSRVP1(.ORTIU,ORDOCIEN)          ; DBIA #4331
    198         S ORY=+$$CHKWKL^TIUPXAP2(ORDOCIEN,ORTIU(0))  ; DBIA #4332
    199         Q
     1ORWPCE2 ; ISL/JM - wrap calls to PCE ;9/25/2001
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,173,195**;Dec 17, 1997
     3GETSET(ORWLST,ORWFILE,ORWFIELD,ORWNULL) ;gets set of codes
     4 ; ORWLST(n)=code^text for code
     5 N ORWPCE,ORWPCEL,ORWPCEC,ORWPCELO,ORWPCEHI,ORWPCECD,ORWPCET
     6 S ORWPCELO="abcdefghijklmnopqrstuvwxyz"
     7 S ORWPCEHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
     8 D FIELD^DID(ORWFILE,ORWFIELD,"","POINTER","ORWPCE","ORWPCE")
     9 S ORWPCEL=$L(ORWPCE("POINTER"),";")-1
     10 F ORWPCEC=1:1:ORWPCEL D
     11 . S ORWPCECD=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",1)
     12 . S ORWPCET=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",2)
     13 . S ORWLST(ORWPCEC)=ORWPCECD_"^"_$E(ORWPCET)_$TR($E(ORWPCET,2,99),ORWPCEHI,ORWPCELO)
     14 S:$G(ORWNULL) ORWLST(0)="@^(None selected)"
     15 Q
     16 ;
     17IMMTYPE(ORWLST) ;get the list of active immunizations
     18 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
     19 F  S BINDEX=$O(^AUTTIMM("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
     20 Q
     21 ;
     22SKTYPE(ORWLST) ;get the list of active skin test
     23 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
     24 F  S BINDEX=$O(^AUTTSK("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTSK(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
     25 Q
     26 ;
     27EDTTYPE(ORWLST) ;get the list of active education topics
     28 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
     29 F  S BINDEX=$O(^AUTTEDT("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTEDT(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
     30 Q
     31 ;
     32HFTYPE(ORWLST,ADDCATS) ;get the list of active  health factors
     33 N IEN,CNT,BINDEX,REC
     34 S (IEN,CNT,BINDEX)=0,ADDCATS=+$G(ADDCATS)
     35 F  S BINDEX=$O(^AUTTHF("B",BINDEX)) Q:BINDEX']""  D
     36 .F  S IEN=$O(^AUTTHF("B",BINDEX,IEN)) Q:'+IEN  D
     37 ..S REC=$G(^AUTTHF(IEN,0))
     38 ..I +$P(REC,U,11) S REC=""
     39 ..I 'ADDCATS,$P(REC,U,10)="C" S REC=""
     40 ..I REC'="" D
     41 ...S CNT=CNT+1,ORWLST(CNT)=IEN_U_$P(REC,U)
     42 ...I ADDCATS S ORWLST(CNT)=ORWLST(CNT)_U_$P(REC,U,10)_U_$P(REC,U,3)
     43 Q
     44 ;
     45EXAMTYPE(ORWLST) ;get the list of active exams
     46 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
     47 F  S BINDEX=$O(^AUTTEXAM("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTEXAM(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
     48 Q
     49 ;
     50TRTTYPE(ORWLST) ;get the list of active treatments
     51 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0
     52 F  S BINDEX=$O(^AUTTTRT("B",BINDEX)) Q:BINDEX']""  F  S IEN=$O(^(BINDEX,IEN)) Q:'+IEN  I $D(^AUTTTRT(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^")
     53 Q
     54 ;
     55ACTIVPRV(ORRETURN,ORWPROV,ORWDT) ;get if provider is active or not
     56 S ORRETURN=$$ACTIVPRV^PXAPI(ORWPROV,ORWDT)
     57 Q
     58GETVISIT(VISIT,IEN,DFN,VSITSTR) ;Get the visit IEN
     59 I +$G(IEN)<1 D  I 1
     60 .S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";"))
     61 E  S VISIT=$P(^TIU(8925,IEN,0),U,3)
     62 Q
     63GAFOK(ORY) ; Returns true if all supporting MH GAF Code exists
     64 S ORY=0
     65 I $T(GAFHX^YSGAFAPI)'="",$T(ENT^YSGAFAP1)'="" S ORY=1
     66 Q
     67MHCLINIC(ORY,ORIEN)     ; See if this is a mental health clinic
     68 I $T(MHCLIN^SDUTL2)="" S ORY=1
     69 E  S ORY=$$MHCLIN^SDUTL2(ORIEN)
     70 Q
     71LOADGAF(ORY,ORINPUT) ; Retrieve GAF scores
     72 D GAFHX^YSGAFAPI(.ORY,.ORINPUT)
     73 Q
     74SAVEGAF(ORY,ORINPUT) ; Save new GAF score
     75 N ORDATA
     76 D ENT^YSGAFAP1(.ORDATA,.ORINPUT)
     77 S ORY=($G(ORDATA(1))="[DATA]")
     78 Q
     79FORCE(ORY,USER,LOC) ; Retrieve FORCE GUI PCE Entry for a given User/Location
     80 N SRV,ORTMP,ORERR
     81 S USER=$G(USER,DUZ)
     82 S SRV=$P($G(^VA(200,USER,5)),U)
     83 D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE FORCE PCE ENTRY","Q",.ORERR)
     84 S ORY=+$P($G(ORTMP(1)),U,2)
     85 Q
     86HASCPT(ORY,ORLIST)        ; Returns true if there are any mapped CPT Codes
     87 N IEN,IDX,FOUND
     88 S IDX=0
     89 F  S IDX=$O(ORLIST(IDX)) Q:'+IDX  D
     90 . S FOUND=0
     91 . S IEN=$$FIND1^DIC(811.1,"","QX",ORLIST(IDX))
     92 . I +IEN S FOUND=+$$GET1^DIQ(811.1,IEN,.05,"I")
     93 . S ORY(IDX)=ORLIST(IDX)_"="_FOUND
     94 Q
     95ASKPCE(ORY,USER,LOC) ; Returns ORWPCE ASK ENCOUNTER UPDATE parameter value
     96 N SRV,ORTMP,ORERR
     97 S USER=$G(USER,DUZ)
     98 S SRV=$P($G(^VA(200,USER,5)),U)
     99 D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE ASK ENCOUNTER UPDATE","Q",.ORERR)
     100 S ORY=+$P($G(ORTMP(1)),U,2)
     101 Q
     102GAFURL(URL) ;Returns the MH GAF Web Page URL
     103 S URL=""
     104 I $T(GAFURL^YTAPI5)'="" D
     105 .N ORY
     106 .D GAFURL^YTAPI5(.ORY)
     107 .I $G(ORY(1))="[DATA]" S URL=$G(ORY(2))
     108 Q
     109MHTESTOK(ORY) ; Returns True if all supporting MH Test APIs exist
     110 D GAFOK(.ORY)
     111 I +ORY,+$G(DUZ),$T(SAVEIT^YTAPI1)'="",$T(PREVIEW^YTAPI4)'="",$T(SHOWALL^YTAPI3)'="",$T(LISTONE^YTAPI)'="",$T(MHS^PXRMRPCC)'="",$T(MHR^PXRMRPCC)'="",$T(MH^PXRMRPCC)'="" D
     112 . N SRV
     113 . S SRV=$P($G(^VA(200,DUZ,5)),U)
     114 . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM MENTAL HEALTH ACTIVE",1,"Q")
     115 . I +ORY S ORY=1
     116 Q
     117MHATHRZD(ORY,TEST,USER) ;Indicates that user can score test
     118 N ORYS,ORANS
     119 I $T(PRIVL^YTAPI5)="" S ORY=1 Q
     120 S ORY=0
     121 S ORYS("CODE")=TEST
     122 S ORYS("STAFF")=USER
     123 D PRIVL^YTAPI5(.ORANS,.ORYS)
     124 I $G(ORANS(1))="[DATA]" S ORY=+$P($G(ORANS(2)),U,1)
     125 Q
     126ANYTIME(ORY) ;Returns status of the ORWPCE ANYTIME ENCOUNTERS parameter
     127 N SRV
     128 S SRV=$P($G(^VA(200,DUZ,5)),U)
     129 S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE ANYTIME ENCOUNTERS",1,"Q")
     130 I +ORY S ORY=1
     131 Q
     132AUTOVSIT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type
     133 N SRV
     134 S SRV=$P($G(^VA(200,DUZ,5)),U)
     135 S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO VISIT TYPE",1,"Q")
     136 I +ORY S ORY=1
     137 S ORY='ORY
     138 Q
     139DOCHKOUT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type
     140 N SRV
     141 S SRV=$P($G(^VA(200,DUZ,5)),U)
     142 S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO CHECKOUT",1,"Q")
     143 I +ORY S ORY=1
     144 S ORY='ORY
     145 Q
     146CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type
     147 N ORY
     148 D DOCHKOUT(.ORY,LOC)
     149 Q ORY
     150EXCLUDED(ORY,LOC,TYPE) ; Returns list of excluded PCE data elements
     151 N SRV,PARAM
     152 S PARAM=$S(TYPE=1:"IMMUNIZATIONS",TYPE=2:"SKIN TESTS",TYPE=3:"PATIENT ED",TYPE=4:"HEALTH FACTORS",TYPE=5:"EXAMS",1:"")
     153 Q:PARAM=""
     154 S SRV=$P($G(^VA(200,DUZ,5)),U)
     155 S PARAM="ORWPCE EXCLUDE "_PARAM
     156 D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG",PARAM,"Q",.ORERR)
     157 Q
     158ISCLINIC(ORY,ORLOC) ; Returns TRUE if location is a clinic
     159 N ORTYP
     160 S ORY=0
     161 S ORTYP=$$GET1^DIQ(44,+ORLOC,2,"I")
     162 I (ORTYP="C")!(ORTYP="M") S ORY=1
     163 Q
     164HNCOK(ORY) ; Returns true if Head and/or Neck Cancer is enabled
     165 S ORY=0
     166 I $$PATCH^XPDUTL("DG*5.3*397"),$$PATCH^XPDUTL("SD*5.3*244"),$$PATCH^XPDUTL("PX*1.0*111"),$$PATCH^XPDUTL("IVM*2.0*46") S ORY=1
     167 Q
     168 ;
     169CODACTIV(ORY,ORCODE,ORAPP,ORDATE)       ; Is code active on the given date?
     170 ; Remote procedure:  ORWPCE ACTIVE CODE
     171 ; ORCODE = ICD or CPT code to be checked
     172 ; ORAPP  = "ICD" or "CHP"
     173 ; ORDATE = Date to be checked (defaults to current date)
     174 S:'+$G(ORDATE) ORDATE=DT
     175 S ORY=1
     176 I ORAPP="ICD" D
     177 . S ORY=+$$STATCHK^ICDAPIU(ORCODE,ORDATE)
     178 E  I ORAPP="CHP" D
     179 . S ORY=+$$STATCHK^ICPTAPIU(ORCODE,ORDATE)
     180 Q
     181ICDACTIV(ORCODE,ORDATE) ; Check for active ICD code
     182 D CODACTIV(.ORY,ORCODE,"ICD",$G(ORDATE))
     183 Q +ORY
     184CPTACTIV(ORCODE,ORDATE) ; Check for active CPT code
     185 D CODACTIV(.ORY,ORCODE,"CHP",$G(ORDATE))
     186 Q +ORY
     187CXNOSHOW(ORY,ORDOCIEN) ; Should workload requirement be skipped for this note's visit?
     188 ; RETURN VALUE:  0=SKIP ALL GUI WORKLOAD REQUIREMENTS
     189 ;                1=CONTINUE WITH OTHER GUI WORKLOAD LOGIC
     190 N ORTIU
     191 D DOCPARM^TIUSRVP1(.ORTIU,ORDOCIEN)          ; DBIA #4331
     192 S ORY=+$$CHKWKL^TIUPXAP2(ORDOCIEN,ORTIU(0))  ; DBIA #4332
     193 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m

    r613 r623  
    1 ORWPS   ; SLC/KCM/JLI/REV/CLA - Meds Tab; 02/11/2008
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243**;Dec 17, 1997;Build 242
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 COVER(LST,DFN)  ; retrieve meds for cover sheet
    5         K ^TMP("PS",$J)
    6         D OCL^PSOORRL(DFN,"","")
    7         N ILST,ITMP,X S ILST=0
    8         S ITMP="" F  S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP  D
    9         . S X=^TMP("PS",$J,ITMP,0)
    10         . I '$L($P(X,U,2)) S X="??"  ; show something if drug empty
    11         . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
    12         . E  S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)
    13         K ^TMP("PS",$J)
    14         Q
    15 DT(X)   ; -- Returns FM date for X
    16         N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
    17         Q Y
    18         ;
    19 ACTIVE(LST,DFN,USER,VIEW,UPDATE)        ; retrieve active inpatient & outpatient meds
    20         K ^TMP("PS",$J)
    21         K ^TMP("ORACT",$J)
    22         N BEG,END,ERROR,CTX,STVIEW
    23         S (BEG,END,CTX)=""
    24         S VIEW=+$G(VIEW)
    25         S UPDATE=+$G(UPDATE)
    26         I VIEW=0,UPDATE=0 S VIEW=1
    27         S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
    28         I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
    29         S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
    30         S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2))
    31         I +$G(USER)=0 S USER=DUZ
    32         I UPDATE=1 D
    33         .S STVIEW=$$GET^XPAR($G(USER)_";VA(200,","OR MEDS TAB SORT",1,"I")
    34         .I VIEW>0,+STVIEW'=VIEW D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR) S STVIEW=VIEW
    35         .I VIEW=0,+STVIEW=0 D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR) S STVIEW=1,VIEW=1
    36         .I VIEW=0,+STVIEW'=VIEW S VIEW=+STVIEW
    37         .S LST(0)=STVIEW
    38         D OCL^PSOORRL(DFN,BEG,END,VIEW)
    39         N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0
    40         S ITMP="" F  S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP  D
    41         . K INSTRUCT,COMMENTS,REASON
    42         . K ^TMP("ORACT",$J,"COMMENTS")
    43         . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
    44         . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0)
    45         . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D
    46         . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing
    47         . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
    48         . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP"
    49         . N LOC,LOCEX S (LOC,LOCEX)=""
    50         . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0))
    51         . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW
    52         . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV"          ;non-VA med
    53         . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV"
    54         . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV"
    55         . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP)
    56         . I TYPE="OP" D OPINST(.INSTRUCT,ITMP)
    57         . I TYPE="IV" D IVINST(.INSTRUCT,ITMP)
    58         . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP)
    59         . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO")
    60         . M COMMENTS=@COMMENTS
    61         . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1)
    62         . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT)
    63         . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS
    64         . E  S LST($$NXT)="~"_TYPE_U_FIELDS
    65         . S J=0 F  S J=$O(INSTRUCT(J)) Q:'J  S LST($$NXT)=INSTRUCT(J)
    66         . S J=0 F  S J=$O(COMMENTS(J)) Q:'J  S LST($$NXT)="t"_COMMENTS(J)
    67         . S J=0 F  S J=$O(REASON(J)) Q:'J  S LST($$NXT)="t"_REASON(J)
    68         K ^TMP("PS",$J)
    69         K ^TMP("ORACT",$J)
    70         Q
    71 NXT()   ; increment ILST
    72         S ILST=ILST+1
    73         Q ILST
    74         ;
    75 UDINST(Y,INDEX) ; assembles instructions for a unit dose order
    76         N I,X,RST
    77         S X=^TMP("PS",$J,INDEX,0)
    78         S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
    79         S @RST@(1)=" "_$P(X,U,2),@RST=1
    80         S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
    81         I $L(X) S @RST=2,@RST@(2)=X
    82         E  S @RST=1 D SETMULT(.RST,INDEX,"SIG")
    83         S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2)
    84         D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH")
    85         F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
    86         M Y=@RST K @RST
    87         Q
    88 OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
    89         N I,X,RST
    90         S X=^TMP("PS",$J,INDEX,0)
    91         S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
    92         S @RST@(1)=" "_$P(X,U,2),@RST=1
    93         I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_"  Qty: "_$P(X,U,12)
    94         I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days"
    95         D SETMULT(RST,INDEX,"SIG")
    96         I @RST=1 D
    97         . D SETMULT(RST,INDEX,"SIO")
    98         . D SETMULT(RST,INDEX,"MDR")
    99         . D SETMULT(RST,INDEX,"SCH")
    100         S @RST@(2)="\ Sig: "_$G(@RST@(2))
    101         F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
    102         M Y=@RST K @RST
    103         Q
    104 IVINST(Y,INDEX) ; assembles instructions for an IV order
    105         N SOLN1,I,RST,IVDUR,CNT
    106         S IVDUR=""
    107         S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
    108         S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1
    109         D SETMULT(RST,INDEX,"B")
    110         I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1)
    111         S SOLN1=@RST+1
    112         S CNT=@RST
    113         D SETMULT(RST,INDEX,"MDR")
    114         I $D(^TMP("PS",$J,INDEX,"SCH",1,0)) S @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$J,INDEX,"SCH",1,0)
    115         F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ")
    116         I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999)
    117         S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
    118         S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0))
    119         I $L(IVDUR) D
    120         . N DURU,DURV S DURU="",DURV=0
    121         . I IVDUR["dose" D  Q
    122         . .S DURV=$P(IVDUR,"doses",2)
    123         . .S IVDUR="for a total of "_+DURV_$S(+DURV=1:"dose",+DURV>1:" doses",1:" dose")
    124         . .S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
    125         . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
    126         . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
    127         . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
    128         . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
    129         . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
    130         . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
    131         M Y=@RST K @RST
    132         Q
    133 NVINST(Y,INDEX) ; assembles instructions for a non-VA med
    134         N I,X,RST
    135         S X=^TMP("PS",$J,INDEX,0)
    136         S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
    137         S @RST@(1)=" "_$P(X,U,2),@RST=1
    138         D SETMULT(RST,INDEX,"SIG")
    139         I @RST=1 D
    140         . D SETMULT(RST,INDEX,"SIO")
    141         . D SETMULT(RST,INDEX,"MDR")
    142         . D SETMULT(RST,INDEX,"SCH")
    143         S @RST@(2)="\ "_$G(@RST@(2))
    144         F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
    145         M Y=@RST K @RST
    146         Q
    147 NVREASON(ORR,NVSDT,INDEX)       ; assembles start date and reasons for a non-VA med
    148         N ORI,J,X,ORN,ORA
    149         S ORI=0 K ORR
    150         S X=^TMP("PS",$J,INDEX,0)
    151         S ORN=+$P(X,U,8)
    152         I $D(^OR(100,ORN,0)) D
    153         .S NVSDT=$P(^OR(100,ORN,0),U,8)
    154         .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D
    155         ..S J=0 F  S J=$O(ORA(J)) Q:J<1  S ORI=ORI+1,ORR(ORI)=ORA(J)
    156         Q
    157 SETMULT(Y,INDEX,SUB)    ; appends the multiple at the subscript to Y
    158         N I,X,J
    159         S J=$G(@Y)
    160         S I=0 F  S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I  S X=$G(^(I,0)) D
    161         . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2)
    162         . S J=J+1,@Y@(J)=X
    163         S @Y=J
    164         Q
    165 COMPRESS(Y)     ; concatenate Y subscripts into smallest possible number
    166         N I,J,X S J=1,X(J)=""
    167         S I=0 F  S I=$O(Y(I)) Q:'I  D
    168         . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)=""
    169         . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I)
    170         K Y M Y=X
    171         Q
    172 DETAIL(ROOT,DFN,ID)     ; -- show details for a med order
    173         K ^TMP("ORXPND",$J)
    174         N LCNT,ORVP
    175         S LCNT=0,ORVP=DFN_";DPT("
    176         D MEDS^ORCXPND1
    177         S ROOT=$NA(^TMP("ORXPND",$J))
    178         Q
    179 MEDHIST(ORROOT,DFN,ORIFN)       ; -- show admin history for a med  (RV)
    180         N ORPSID,HPIV,ISIV,CKPKG,ORPHMID
    181         N CLINDISP,IVDIAL
    182         S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),ISIV=0,HPIV=0
    183         S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT
    184         S ORPHMID=$G(^OR(100,+ORIFN,4))  ;Pharmacy order number
    185         S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
    186         S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
    187         S CLINDISP=$O(^ORD(100.98,"B","C RX",""))
    188         S IVDIAL=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
    189         S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
    190         ;if the order is pending or the order has no pharmacy #
    191         ;or the order is not in the Display Group IV MEDICATION
    192         ; then use the Orderable item number to get the MAH.
    193         I (ORPHMID["P")!(ORPHMID="") D  Q
    194         . I '$L($T(HISTORY^PSBMLHS)) D  Q
    195         . . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
    196         . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)  ; DBIA #3459 for BCMA v2.0
    197         ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
    198         I ($P($G(^OR(100,+ORIFN,0)),U,11)=ISIV)!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV)!(($P($G(^OR(100,+ORIFN,0)),U,11)=CLINDISP)&(+$P($G(^OR(100,+ORIFN,0)),U,5)=IVDIAL)) D  Q
    199         . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
    200         . I CKPKG D
    201         . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID)  ;DBIA #3955
    202         . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order."
    203         I '$L($T(HISTORY^PSBMLHS)) D  Q
    204         . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
    205         D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)  ; DBIA #3459 for BCMA v2.0
    206         Q
    207         ;
    208 REASON(ORY)     ; -- Return Non-VA Med Statement/Reasons
    209         N ORE
    210         D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
    211         Q
     1ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 05/22/03 ; 5/18/07 10:18am
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275**;Dec 17, 1997;Build 7
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4COVER(LST,DFN)  ; retrieve meds for cover sheet
     5 K ^TMP("PS",$J)
     6 D OCL^PSOORRL(DFN,"","")  ;DBIA #2400
     7 N ILST,ITMP,X S ILST=0
     8 S ITMP="" F  S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP  D
     9 . S X=^TMP("PS",$J,ITMP,0)
     10 . I '$L($P(X,U,2)) S X="??"  ; show something if drug empty
     11 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
     12 . E  S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)
     13 K ^TMP("PS",$J)
     14 Q
     15DT(X) ; -- Returns FM date for X
     16 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
     17 Q Y
     18 ;
     19ACTIVE(LST,DFN) ; retrieve active inpatient & outpatient meds
     20 K ^TMP("PS",$J)
     21 K ^TMP("ORACT",$J)
     22 N BEG,END,CTX
     23 S (BEG,END,CTX)=""
     24 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
     25 I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
     26 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
     27 S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2))
     28 D OCL^PSOORRL(DFN,BEG,END)  ;DBIA #2400
     29 N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0
     30 S ITMP="" F  S ITMP=$O(^TMP("PS",$J,ITMP),-1) Q:'ITMP  D
     31 . K INSTRUCT,COMMENTS,REASON
     32 . K ^TMP("ORACT",$J,"COMMENTS")
     33 . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
     34 . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0)
     35 . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D
     36 . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing
     37 . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
     38 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP"
     39 . N LOC,LOCEX S (LOC,LOCEX)=""
     40 . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0))
     41 . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW  DBIA #964
     42 . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV"          ;non-VA med
     43 . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV"
     44 . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV"
     45 . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP)
     46 . I TYPE="OP" D OPINST(.INSTRUCT,ITMP)
     47 . I TYPE="IV" D IVINST(.INSTRUCT,ITMP)
     48 . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP)
     49 . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO")
     50 . M COMMENTS=@COMMENTS
     51 . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1)
     52 . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT)
     53 . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS
     54 . E  S LST($$NXT)="~"_TYPE_U_FIELDS
     55 . S J=0 F  S J=$O(INSTRUCT(J)) Q:'J  S LST($$NXT)=INSTRUCT(J)
     56 . S J=0 F  S J=$O(COMMENTS(J)) Q:'J  S LST($$NXT)="t"_COMMENTS(J)
     57 . S J=0 F  S J=$O(REASON(J)) Q:'J  S LST($$NXT)="t"_REASON(J)
     58 K ^TMP("PS",$J)
     59 K ^TMP("ORACT",$J)
     60 Q
     61NXT() ; increment ILST
     62 S ILST=ILST+1
     63 Q ILST
     64 ;
     65UDINST(Y,INDEX) ; assembles instructions for a unit dose order
     66 N I,X,RST
     67 S X=^TMP("PS",$J,INDEX,0)
     68 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
     69 S @RST@(1)=" "_$P(X,U,2),@RST=1
     70 S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
     71 I $L(X) S @RST=2,@RST@(2)=X
     72 E  S @RST=1 D SETMULT(.RST,INDEX,"SIG")
     73 S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2)
     74 D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH")
     75 F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
     76 M Y=@RST K @RST
     77 Q
     78OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
     79 N I,X,RST
     80 S X=^TMP("PS",$J,INDEX,0)
     81 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
     82 S @RST@(1)=" "_$P(X,U,2),@RST=1
     83 I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_"  Qty: "_$P(X,U,12)
     84 I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days"
     85 D SETMULT(RST,INDEX,"SIG")
     86 I @RST=1 D
     87 . D SETMULT(RST,INDEX,"SIO")
     88 . D SETMULT(RST,INDEX,"MDR")
     89 . D SETMULT(RST,INDEX,"SCH")
     90 S @RST@(2)="\ Sig: "_$G(@RST@(2))
     91 F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
     92 M Y=@RST K @RST
     93 Q
     94IVINST(Y,INDEX) ; assembles instructions for an IV order
     95 N SOLN1,I,RST,IVDUR
     96 S IVDUR=""
     97 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
     98 S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1
     99 D SETMULT(RST,INDEX,"B")
     100 I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1)
     101 S SOLN1=@RST+1
     102 D SETMULT(RST,INDEX,"SCH") S:$D(@RST@(SOLN1)) @RST@(SOLN1)=" "_@RST@(SOLN1)
     103 F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ")
     104 I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999)
     105 S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
     106 S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0))
     107 I $L(IVDUR) D
     108 . N DURU,DURV S DURU="",DURV=0
     109 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
     110 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
     111 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
     112 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
     113 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
     114 . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
     115 M Y=@RST K @RST
     116 Q
     117NVINST(Y,INDEX) ; assembles instructions for a non-VA med
     118 N I,X,RST
     119 S X=^TMP("PS",$J,INDEX,0)
     120 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
     121 S @RST@(1)=" "_$P(X,U,2),@RST=1
     122 D SETMULT(RST,INDEX,"SIG")
     123 I @RST=1 D
     124 . D SETMULT(RST,INDEX,"SIO")
     125 . D SETMULT(RST,INDEX,"MDR")
     126 . D SETMULT(RST,INDEX,"SCH")
     127 S @RST@(2)="\ "_$G(@RST@(2))
     128 F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
     129 M Y=@RST K @RST
     130 Q
     131NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med
     132 N ORI,J,X,ORN,ORA
     133 S ORI=0 K ORR
     134 S X=^TMP("PS",$J,INDEX,0)
     135 S ORN=+$P(X,U,8)
     136 I $D(^OR(100,ORN,0)) D
     137 .S NVSDT=$P(^OR(100,ORN,0),U,8)
     138 .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D
     139 ..S J=0 F  S J=$O(ORA(J)) Q:J<1  S ORI=ORI+1,ORR(ORI)=ORA(J)
     140 Q
     141SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y
     142 N I,X,J
     143 S J=$G(@Y)
     144 S I=0 F  S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I  S X=$G(^(I,0)) D
     145 . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2)
     146 . S J=J+1,@Y@(J)=X
     147 S @Y=J
     148 Q
     149COMPRESS(Y) ; concatenate Y subscripts into smallest possible number
     150 N I,J,X S J=1,X(J)=""
     151 S I=0 F  S I=$O(Y(I)) Q:'I  D
     152 . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)=""
     153 . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I)
     154 K Y M Y=X
     155 Q
     156DETAIL(ROOT,DFN,ID) ; -- show details for a med order
     157 K ^TMP("ORXPND",$J)
     158 N LCNT,ORVP
     159 S LCNT=0,ORVP=DFN_";DPT("
     160 D MEDS^ORCXPND1
     161 S ROOT=$NA(^TMP("ORXPND",$J))
     162 Q
     163MEDHIST(ORROOT,DFN,ORIFN)       ; -- show admin history for a med  (RV)
     164 N ORPSID,HPIV,ISIV,CKPKG,ORPHMID
     165 S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),(HPIV,ISIV)=0
     166 S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT
     167 S ORPHMID=$G(^OR(100,+ORIFN,4))  ;Pharmacy order number
     168 S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
     169 S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
     170 S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
     171 ;if the order is pending or the order has no pharmacy #
     172 ;or the order is not in the Display Group IV MEDICATION
     173 ; then use the Orderable item number to get the MAH.
     174 I (ORPHMID["P")!(ORPHMID="") D  Q
     175 . I '$L($T(HISTORY^PSBMLHS)) D  Q
     176 . . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
     177 . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)  ; DBIA #3459 for BCMA v2.0
     178 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MAH
     179 I $P($G(^OR(100,+ORIFN,0)),U,11)=ISIV!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV) D  Q
     180 . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
     181 . I CKPKG D
     182 . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID)  ;DBIA #3955
     183 . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order."
     184 I '$L($T(HISTORY^PSBMLHS)) D  Q
     185 . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
     186 D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)  ; DBIA #3459 for BCMA v2.0
     187 Q
     188 ;
     189REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
     190 N ORE
     191 D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
     192 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m

    r613 r623  
    1 ORWPT   ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05  10:50
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; Ref. to ^UTILITY via IA 10061
    5         ;
    6 IDINFO(REC,DFN) ; Return identifying information for a patient
    7         ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME
    8         N X0,X1,X101,X3,XV  ; name/dob/sex/ssn, ward, room-bed, sc%, vet
    9         S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET"))
    10         S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249
    11         Q
    12 PTINQ(REF,DFN)  ; Return formatted pt inquiry report
    13         K ^TMP("ORDATA",$J,1)
    14         D DGINQ^ORCXPND1(DFN)
    15         S REF=$NA(^TMP("ORDATA",$J,1))
    16         Q
    17 SCDIS(LST,DFN)  ; Return service connected % and rated disabilities
    18         N VAEL,VAERR,I,ILST,DIS,SC,X
    19         D ELIG^VADPT
    20         S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
    21         I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
    22         S I=0,ILST=1 F  S I=$O(^DPT(DFN,.372,I)) Q:'I  S X=^(I,0) D
    23         . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
    24         . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
    25         . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
    26         I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
    27         Q
    28 SHOW    ; temporary - show patient inquiry screen
    29         N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y
    30         K ^TMP("ORDATA",$J,1)
    31         D DGINQ^ORCXPND1(+Y)
    32         S I=0 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I  W !,^(I)
    33         K ^TMP("ORDATA",$J,1)
    34         Q
    35 SELCHK(REC,DFN) ; Check for sensitive pt
    36         ; SENSITIVE
    37         S REC=$$EN1^ORQPT2(DFN)
    38         Q
    39 DIEDON(VAL,DFN) ; Check for a date of death
    40         S VAL=+$G(^DPT(DFN,.35))
    41         Q
    42 SELECT(REC,DFN) ; Selects patient & returns key information
    43         ;  1    2   3   4    5      6    7    8       9       10      11  12
    44         ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
    45         ; 13  14  15  16
    46         ; SC%^ICN^AGE^TS
    47         ;
    48         ; for CCOW (RV - 2/27/03)  name="-1", location=error message
    49         I '$D(^DPT(+DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q
    50         ;
    51         N X
    52         K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients
    53         S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
    54         S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
    55         S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
    56         ; I $P(REC,U,9) D EN2^ORQPT2(DFN)  ;update DG security log ; DG249
    57         S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
    58         S:'$D(IOST) IOST="P-OTHER"
    59         S $P(REC,U,11)=0
    60         D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
    61         I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
    62         S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3))
    63         S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty
    64         K VAEL,VAERR ;VADPT call to kill?
    65         S ^DISV(DUZ,"^DPT(")=DFN
    66         Q
    67 SHARE(VAL,IP,HWND,DFN)  ; Set global to share DFN with other applications
    68         K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J)
    69         K ^TMP("ORWDXMQ",$J)
    70         S ^TMP("ORWCHART",$J,IP,HWND)=DFN
    71         Q
    72 BYWARD(LST,WARD)        ; Return a list of patients in a ward
    73         N ILST,DFN
    74         I +$G(WARD)<1 S LST(1)="^No ward identified" Q
    75         S (ILST,DFN)=0
    76         S WARD=$P(^DIC(42,WARD,0),"^")   ;DBIA #36
    77         F  S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0  D
    78         . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101))
    79         I ILST<1 S LST(1)="^No patients found."
    80         Q
    81 LAST5(LST,ID)   ; Return a list of patients matching A9999 identifiers
    82         N I,IEN,XREF
    83         S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS")
    84         F  S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN  D
    85         . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN)  ; DG249
    86         Q
    87         ;
    88 LAST5RPL(LST,ID)        ; ; Return list matching A9999 id's, but from RPL only.
    89         N ORRPL,ORCNT,ORPT,ORPIEN
    90         ; IA ____ allows read access to NEW PERSON file node 101:
    91         S ORRPL=$G(^VA(200,DUZ,101))
    92         S ORRPL=$P(ORRPL,U,2)
    93         I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
    94         ;
    95         S (ORCNT,ORPT)=0
    96         F  S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT  D
    97         .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0))
    98         .I ((ORPIEN<0)!(ORPIEN="")) Q
    99         .S ORCNT=ORCNT+1
    100         .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
    101         ;
    102         Q
    103         ;
    104 FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered
    105         N I,IEN
    106         S (I,IEN)=0
    107         F  S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN  D
    108         . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN)  ; DG249
    109         Q
    110         ;
    111 FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only.
    112         N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN
    113         ; IA ____ allows read access to NEW PERSON file node 101:
    114         S ORRPL=$G(^VA(200,DUZ,101))
    115         S ORRPL=$P(ORRPL,U,2)
    116         I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
    117         ;
    118         S (ORCNT,ORPT)=0
    119         F  S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT  D
    120         .S ORLPT=0
    121         .F  S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT  D
    122         ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0))
    123         ..I ((ORPIEN<0)!(ORPIEN="")) Q
    124         ..I (ORPIEN'=ORPT) Q
    125         ..S ORCNT=ORCNT+1
    126         ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
    127         ;
    128         Q
    129         ;
    130 TOP(LST)        ; Return top for all patients list (last selected for now)
    131         N IEN
    132         S IEN=$G(^DISV(DUZ,"^DPT("))
    133         I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U)
    134         Q
    135 ENCTITL(REC,DFN,LOC,PROV)       ; Return external values for encounter
    136         ; LOCNAME^LOCABBR^ROOMBED^PROVNAME
    137         S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2)
    138         S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U)
    139         S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U)
    140         Q
    141 LISTALL(Y,FROM,DIR)     ; Return a bolus of patient names.  From is either Name or IEN^Name.
    142         N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0
    143         I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR)
    144         F  S FROM=$O(^DPT("B",FROM),DIR) Q:FROM=""  D  Q:I=CNT
    145         . S IEN=FROMIEN,FROMIEN=0 F  S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN  D  Q:I=CNT
    146         . . S ORIDNAME=""
    147         . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name.
    148         . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
    149         . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1  ;"   ("_X_")"
    150         Q
    151 APPTLST(LST,DFN)        ; return a list of appointments
    152         ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS
    153         N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J)  ;IA 10061
    154         S VASD("F")=$$HTFM^XLFDT($H-30,1)
    155         S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359"
    156         S VASD("W")="123456789"
    157         D SDA^ORQRY01(.ERR,.ERRMSG)
    158         I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q
    159         S I=0 F  S I=$O(^UTILITY("VASD",$J,I)) Q:'I  D
    160         . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3)
    161         K ^UTILITY("VASD",$J)
    162         Q
    163 ADMITLST(LST,DFN)       ; return a list of admissions
    164         ; MOVETIME^LOCIEN^LOCNAME^TYPE
    165         N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0
    166         S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D
    167         . S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D
    168         . . N VSTR,TIUDA
    169         . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q
    170         . . S MTIM=$P(X0,U)
    171         . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
    172         . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
    173         . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR)
    174         . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA
    175         Q
    176 CLINRNG(LST)    ; return date ranges for clinic appointments
    177         S LST(1)="T;T^Today"
    178         S LST(2)="T+1;T+1^Tomorrow"
    179         S LST(3)="T-1;T-1^Yesterday"
    180         S LST(4)="T-7;T^Past Week"
    181         S LST(5)="T-31;T^Past Month"
    182         S LST(6)="S^Specify Date Range..."
    183         Q
    184         ;
    185         N %,%H,X,SUNDAY,START
    186         S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1)
    187         S LST(2)=X_";"_X_"^Tomorrow"
    188         S X=+$H F  Q:X#7=3  S X=X-1                        ; $H#7=3 is Sunday
    189         S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
    190         S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
    191         S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month"
    192         S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0)
    193         S LST(6)=X_"01;"_X_"31^Next Month"
    194         S LST(7)="^Specify Dates"
    195         Q
    196 DFLTSRC(VAL)    ; return default patient list source (T, W, C, P, S)
    197         N SRV S SRV=+$G(^VA(200,DUZ,5))
    198         S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
    199         Q
    200 SAVDFLT(OK,X)   ; save new default patient list settings (X=type^ien^sdt;edt)
    201         G SAVDFLT^ORWPT1
    202         ;
    203 DISCHRG(Y,DFN,ADMITDT)  ; Get discharge movement information
    204         N VAIP
    205         I +$G(ADMITDT)=0 S Y=DT Q
    206         S VAIP("D")=ADMITDT D 52^VADPT
    207         I +VAIP(17)=0 S Y=DT Q
    208         S Y=+VAIP(17,1)
    209         Q
    210 CWAD(Y,DFN)     ;  returns CWAD flags for a patient
    211         S Y=$$CWAD^ORQPT2(DFN)
    212         Q
    213 LEGACY(ORLST,DFN)       ; return message if data on the legacy system
    214         ; ORLST(0)=1 if data,  ORLST(n)=display message if data
    215         S ORLST(0)=0
    216         I $L($T(HXDATA^A7RDPAGU)) D
    217         . D HXDATA^A7RDPAGU(.ORLST,DFN)
    218         . I $O(ORLST(0)) S ORLST(0)=1
    219         Q
    220 INPLOC(REC,DFN) ; Return a patient's current location
    221         N X
    222         S X=$G(^DPT(DFN,.102)),REC=0
    223         I X S X=$P($G(^DGPM(X,0)),U,6)
    224         I X S REC=+$G(^DIC(42,X,44))
    225         I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1)
    226         I X S X=$P($G(^DIC(42,X,0)),U,3)
    227         S $P(REC,U,3)=X
    228         Q
    229 AGE(DFN,BEG)    ; returns age based on date of birth and date of death (or DT)
    230         N END,X
    231         S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT)
    232         S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7))
    233         Q X
    234 ROK(X)  ; Routine OK (in UCI) (NDBI)
    235         S X=$G(X) Q:'$L(X) 0  Q:$L(X)>8 0  X ^%ZOSF("TEST") Q:$T 1  Q 0
    236         ;
    237         ;NDBI(X) ; National Database Integration site 1 = yes  0 = no
    238         ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X
     1ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;11/23/06  10:50
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,269**;Dec 17, 1997 LOCAL ;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License
     8 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06
     9 ;
     10 Q
     11IDINFO(REC,DFN) ; Return identifying information for a patient
     12 ;VWPT BELOW ADD HRN AND ALT HRN
     13 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME^HRN^ALTHRN
     14 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME
     15 N X0,X1,X101,X3,XV  ; name/dob/sex/ssn, ward, room-bed, sc%, vet
     16 S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET"))
     17 ;VWPT ENHANCED
     18 N HRN,ID
     19 S HRN=$$HRN^DGLBPID(DFN)
     20 S ID=$$ID^DGLBPID(DFN)
     21 I (ID=HRN)&(HRN'="") D
     22 .S REC=U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249
     23 E  D
     24 .S REC=$$ID^DGLBPID(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249
     25 ;S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249
     26 ;END VWPT
     27 Q
     28 ;VWPT RETURN HRN .CHECK FOR "sensitive" patients
     29HRNRET(DFN) ;
     30 N IRET
     31 S IRET=$$HRN^DGLBPID(DFN) ;$$HRN^VWVOEDPT(DFN)
     32 ;I (IRET'="")&$$SCREEN^DPTLK1(DFN) Q "*SENSITIVE*"  ;"HRN SENSITIVE"
     33 I (IRET'="") Q "'"_IRET_"'" ;"HRN:"_"'"_IRET_"'"
     34 Q ""
     35 ; END VWPT
     36PTINQ(REF,DFN) ; Return formatted pt inquiry report
     37 K ^TMP("ORDATA",$J,1)
     38 D DGINQ^ORCXPND1(DFN)
     39 S REF=$NA(^TMP("ORDATA",$J,1))
     40 Q
     41SCDIS(LST,DFN) ; Return service connected % and rated disabilities
     42 N VAEL,VAERR,I,ILST,DIS,SC,X
     43 D ELIG^VADPT
     44 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
     45 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
     46 S I=0,ILST=1 F  S I=$O(^DPT(DFN,.372,I)) Q:'I  S X=^(I,0) D
     47 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
     48 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
     49 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
     50 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
     51 Q
     52SHOW ; temporary - show patient inquiry screen
     53 N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y
     54 K ^TMP("ORDATA",$J,1)
     55 D DGINQ^ORCXPND1(+Y)
     56 S I=0 F  S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I  W !,^(I)
     57 K ^TMP("ORDATA",$J,1)
     58 Q
     59SELCHK(REC,DFN) ; Check for sensitive pt
     60 ; SENSITIVE
     61 S REC=$$EN1^ORQPT2(DFN)
     62 Q
     63DIEDON(VAL,DFN) ; Check for a date of death
     64 S VAL=+$G(^DPT(DFN,.35))
     65 Q
     66SELECT(REC,DFN) ; Selects patient & returns key information
     67 ;  1    2   3   4    5      6    7    8       9       10      11  12
     68 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
     69 ;VWPT HRN , ALTERNATE HRN
     70 ; 13  14  15  16  17  18
     71 ; SC%^ICN^AGE^TS^HRN^AltHRN
     72 ; ;
     73 ; ;end vwpt
     74 ;
     75 ;
     76 ; for CCOW (RV - 2/27/03)  name="-1", location=error message
     77 I '$D(^DPT(DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q
     78 ;
     79 N X,ID,HRN
     80 K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients
     81 D VWPT1^ORWPT2 ;moved code to ORWPT2 to save space
     82 S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3))
     83 S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty
     84 D VWPT2^ORWPT2
     85 Q
     86SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications
     87 K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J)
     88 K ^TMP("ORWDXMQ",$J)
     89 S ^TMP("ORWCHART",$J,IP,HWND)=DFN
     90 Q
     91BYWARD(LST,WARD) ; Return a list of patients in a ward
     92 N ILST,DFN
     93 I +$G(WARD)<1 S LST(1)="^No ward identified" Q
     94 S (ILST,DFN)=0
     95 S WARD=$P(^DIC(42,WARD,0),"^")   ;DBIA #36
     96 F  S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0  D
     97 . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101))
     98 I ILST<1 S LST(1)="^No patients found."
     99 Q
     100LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers
     101 N I,IEN,XREF
     102 S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS")
     103 F  S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN  D
     104 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN)  ; DG249
     105 Q
     106 ;
     107LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only.
     108 N ORRPL,ORCNT,ORPT,ORPIEN
     109 ; IA ____ allows read access to NEW PERSON file node 101:
     110 S ORRPL=$G(^VA(200,DUZ,101))
     111 S ORRPL=$P(ORRPL,U,2)
     112 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
     113 ;
     114 S (ORCNT,ORPT)=0
     115 F  S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT  D
     116 .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0))
     117 .I ((ORPIEN<0)!(ORPIEN="")) Q
     118 .S ORCNT=ORCNT+1
     119 .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;$$SSN^DPTLK1(ORPIEN) ; DG249.
     120 ;
     121 Q
     122 ;
     123FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered
     124 N I,IEN
     125 S (I,IEN)=0
     126 F  S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN  D
     127 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN)  ; DG249
     128 Q
     129 ;
     130FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only.
     131 N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN
     132 ; IA ____ allows read access to NEW PERSON file node 101:
     133 S ORRPL=$G(^VA(200,DUZ,101))
     134 S ORRPL=$P(ORRPL,U,2)
     135 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
     136 ;
     137 S (ORCNT,ORPT)=0
     138 F  S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT  D
     139 .S ORLPT=0
     140 .F  S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT  D
     141 ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0))
     142 ..I ((ORPIEN<0)!(ORPIEN="")) Q
     143 ..I (ORPIEN'=ORPT) Q
     144 ..S ORCNT=ORCNT+1
     145 ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;SSN^DPTLK1(ORPIEN) ; DG249.
     146 ;
     147 Q
     148 ;
     149TOP(LST) ; Return top for all patients list (last selected for now)
     150 N IEN
     151 S IEN=$G(^DISV(DUZ,"^DPT("))
     152 I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U)
     153 Q
     154ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter
     155 ; LOCNAME^LOCABBR^ROOMBED^PROVNAME
     156 S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2)
     157 S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U)
     158 S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U)
     159 Q
     160LISTALL(Y,FROM,DIR) ; Return a bolus of patient names.  From is either Name or IEN^Name.
     161 N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0
     162 I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR)
     163 F  S FROM=$O(^DPT("B",FROM),DIR) Q:FROM=""  D  Q:I=CNT
     164 . S IEN=FROMIEN,FROMIEN=0 F  S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN  D  Q:I=CNT
     165 . . S ORIDNAME=""
     166 . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name.
     167 . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
     168 . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1  ;"   ("_X_")"
     169 Q
     170APPTLST(LST,DFN) ; return a list of appointments
     171 ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS
     172 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J)  ;IA 10061
     173 S VASD("F")=$$HTFM^XLFDT($H-30,1)
     174 S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359"
     175 S VASD("W")="123456789"
     176 D SDA^ORQRY01(.ERR,.ERRMSG)
     177 I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q
     178 S I=0 F  S I=$O(^UTILITY("VASD",$J,I)) Q:'I  D
     179 . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3)
     180 K ^UTILITY("VASD",$J)
     181 Q
     182ADMITLST(LST,DFN) ; return a list of admissions
     183 ; MOVETIME^LOCIEN^LOCNAME^TYPE
     184 N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0
     185 S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D
     186 . S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D
     187 . . N VSTR,TIUDA
     188 . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q
     189 . . S MTIM=$P(X0,U)
     190 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
     191 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
     192 . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR)
     193 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA
     194 Q
     195CLINRNG(LST) ; return date ranges for clinic appointments
     196 S LST(1)="T;T^Today"
     197 S LST(2)="T+1;T+1^Tomorrow"
     198 S LST(3)="T-1;T-1^Yesterday"
     199 S LST(4)="T-7;T^Past Week"
     200 S LST(5)="T-31;T^Past Month"
     201 S LST(6)="S^Specify Date Range..."
     202 Q
     203 ;
     204 N %,%H,X,SUNDAY,START
     205 S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1)
     206 S LST(2)=X_";"_X_"^Tomorrow"
     207 S X=+$H F  Q:X#7=3  S X=X-1                        ; $H#7=3 is Sunday
     208 S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
     209 S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
     210 S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month"
     211 S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0)
     212 S LST(6)=X_"01;"_X_"31^Next Month"
     213 S LST(7)="^Specify Dates"
     214 Q
     215DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S)
     216 N SRV S SRV=+$G(^VA(200,DUZ,5))
     217 S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
     218 Q
     219SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt)
     220 G SAVDFLT^ORWPT1
     221 ;
     222DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information
     223 N VAIP
     224 I +$G(ADMITDT)=0 S Y=DT Q
     225 S VAIP("D")=ADMITDT D 52^VADPT
     226 I +VAIP(17)=0 S Y=DT Q
     227 S Y=+VAIP(17,1)
     228 Q
     229CWAD(Y,DFN) ;  returns CWAD flags for a patient
     230 S Y=$$CWAD^ORQPT2(DFN)
     231 Q
     232LEGACY(ORLST,DFN) ; return message if data on the legacy system
     233 ; ORLST(0)=1 if data,  ORLST(n)=display message if data
     234 S ORLST(0)=0
     235 I $L($T(HXDATA^A7RDPAGU)) D
     236 . D HXDATA^A7RDPAGU(.ORLST,DFN)
     237 . I $O(ORLST(0)) S ORLST(0)=1
     238 Q
     239INPLOC(REC,DFN) ; Return a patient's current location
     240 N X
     241 S X=$G(^DPT(DFN,.102)),REC=0
     242 I X S X=$P($G(^DGPM(X,0)),U,6)
     243 I X S REC=+$G(^DIC(42,X,44))
     244 I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1)
     245 I X S X=$P($G(^DIC(42,X,0)),U,3)
     246 S $P(REC,U,3)=X
     247 Q
     248AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT)
     249 N END,X
     250 S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT)
     251 S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7))
     252 Q X
     253ROK(X) ; Routine OK (in UCI) (NDBI)
     254 S X=$G(X) Q:'$L(X) 0  Q:$L(X)>8 0  X ^%ZOSF("TEST") Q:$T 1  Q 0
     255 ;
     256 ;NDBI(X) ; National Database Integration site 1 = yes  0 = no
     257 ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X
     258 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT16.m

    r613 r623  
    1 ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96  15:43
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
    3         ;
    4 IDINFO(ORY,DFN) ; Return identifying information for a patient
    5         ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME
    6         N OR0,OR36,OR1,OR101,VAEL,VAERR
    7         S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101))
    8         D ELIG^VADPT
    9         S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2)
    10         S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U)
    11         I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000
    12         I '$L($P(ORY,U,1)) D
    13         . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
    14         S $P(ORY,U,9)=$P(OR0,U,1)
    15         Q
    16 DEMOG(VAL,DFN)  ; procedure
    17         ; Return common patient demographic info
    18         ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE
    19         S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
    20         S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0))
    21         S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1)
    22         I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1)
    23         Q
    24 PSCNVT(VAL,DFN) ; procedure
    25         ; Call conversion routine for pharmacy (both inpatient and outpatient)
    26         S VAL=0
    27         Q
    28 LISTALL(Y,DIR,FROM)     ; Return a bolus of patient names
    29         N I,IEN,CNT S CNT=44,I=0
    30         ;
    31         I DIR=0 D  ; Forward direction
    32         . F  S FROM=$O(^DPT("B",FROM)) Q:FROM=""  D  Q:I=CNT
    33         . . S IEN=0 F  S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN  D  Q:I=CNT
    34         . . . ; S X=$P($G(^DPT(IEN,0)),"^",9)
    35         . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
    36         . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
    37         . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1  ;"   ("_X_")"
    38         . I $G(Y(CNT))="" S I=I+1,Y(I)=""
    39         ;
    40         I DIR=1 D  ; Reverse direction
    41         . F  S FROM=$O(^DPT("B",FROM),-1) Q:FROM=""  D  Q:I=CNT
    42         . . S IEN=0 F  S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN  D  Q:I=CNT
    43         . . . ; S X=$P($G(^DPT(IEN,0)),"^",9)
    44         . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
    45         . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
    46         . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1  ;"   ("_X_")"
    47         Q
    48 LOOKUP(Y,FROM)  ; Return a set of patient names
    49         N I,X
    50         D FIND^DIC(2,"","","M",FROM)
    51         S I=0,Y=""
    52         F  S I=$O(^TMP("DILIST",$J,1,I)) Q:'I  D
    53         . S X=^TMP("DILIST",$J,"ID",I,.09)
    54         . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
    55         . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X
    56         K ^TMP("DILIST",$J)
    57         Q
    58 GETVSIT(Y,DFN,LOC,ADATE)        ; procedure
    59         ; Return a visit given a patient, location, and date/time
    60         N VSIT,VSITPKG
    61         S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC
    62         S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR"
    63         D ^VSIT
    64         S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q
    65         I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2)
    66         Q
    67 APPTLST(LST,DFN)        ; procedure
    68         ; Return a list of appointments
    69         N I,ILST S ILST=0
    70         D GETAPPT^TIUVSIT(DFN)
    71         S I=0 F  S I=$O(^TMP("TIUVNI",$J,I)) Q:'I  D
    72         . S ILST=ILST+1
    73         . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2)
    74         K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J)
    75         Q
    76 ADMITLST(LST,DFN)       ; procedure
    77         ; Return a list of admissions
    78         N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0
    79         S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D
    80         . S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D
    81         . . S X0=^DGPM(MOV,0)
    82         . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y
    83         . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
    84         . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
    85         . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC
    86         Q
     1ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96  15:43
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
     3 ;
     4IDINFO(ORY,DFN) ; Return identifying information for a patient
     5 ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME
     6 N OR0,OR36,OR1,OR101,VAEL,VAERR
     7 S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101))
     8 D ELIG^VADPT
     9 S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2)
     10 S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U)
     11 I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000
     12 I '$L($P(ORY,U,1)) D
     13 . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
     14 S $P(ORY,U,9)=$P(OR0,U,1)
     15 Q
     16DEMOG(VAL,DFN) ; procedure
     17 ; Return common patient demographic info
     18 ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE
     19 S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
     20 S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0))
     21 S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1)
     22 I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1)
     23 Q
     24PSCNVT(VAL,DFN) ; procedure
     25 ; Call conversion routine for pharmacy (both inpatient and outpatient)
     26 S VAL=0
     27 S:'$D(IOST) IOST="P-OTHER"  ; don't know why broker doesn't define IOST
     28 S VAL=$$OTF^OR3CONV(DFN,1)
     29 ; D EN1^PSOHLUP(DFN,0)
     30 ; D EN^LR7OV2(DFN,0)
     31 ; S VAL=1
     32 Q
     33LISTALL(Y,DIR,FROM) ; Return a bolus of patient names
     34 N I,IEN,CNT S CNT=44,I=0
     35 ;
     36 I DIR=0 D  ; Forward direction
     37 . F  S FROM=$O(^DPT("B",FROM)) Q:FROM=""  D  Q:I=CNT
     38 . . S IEN=0 F  S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN  D  Q:I=CNT
     39 . . . ; S X=$P($G(^DPT(IEN,0)),"^",9)
     40 . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
     41 . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
     42 . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1  ;"   ("_X_")"
     43 . I $G(Y(CNT))="" S I=I+1,Y(I)=""
     44 ;
     45 I DIR=1 D  ; Reverse direction
     46 . F  S FROM=$O(^DPT("B",FROM),-1) Q:FROM=""  D  Q:I=CNT
     47 . . S IEN=0 F  S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN  D  Q:I=CNT
     48 . . . ; S X=$P($G(^DPT(IEN,0)),"^",9)
     49 . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
     50 . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
     51 . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1  ;"   ("_X_")"
     52 Q
     53LOOKUP(Y,FROM) ; Return a set of patient names
     54 N I,X
     55 D FIND^DIC(2,"","","M",FROM)
     56 S I=0,Y=""
     57 F  S I=$O(^TMP("DILIST",$J,1,I)) Q:'I  D
     58 . S X=^TMP("DILIST",$J,"ID",I,.09)
     59 . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99)
     60 . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X
     61 K ^TMP("DILIST",$J)
     62 Q
     63GETVSIT(Y,DFN,LOC,ADATE) ; procedure
     64 ; Return a visit given a patient, location, and date/time
     65 N VSIT,VSITPKG
     66 S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC
     67 S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR"
     68 D ^VSIT
     69 S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q
     70 I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2)
     71 Q
     72APPTLST(LST,DFN) ; procedure
     73 ; Return a list of appointments
     74 N I,ILST S ILST=0
     75 D GETAPPT^TIUVSIT(DFN)
     76 S I=0 F  S I=$O(^TMP("TIUVNI",$J,I)) Q:'I  D
     77 . S ILST=ILST+1
     78 . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2)
     79 K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J)
     80 Q
     81ADMITLST(LST,DFN) ; procedure
     82 ; Return a list of admissions
     83 N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0
     84 S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D
     85 . S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D
     86 . . S X0=^DGPM(MOV,0)
     87 . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y
     88 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
     89 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
     90 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC
     91 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m

    r613 r623  
    1 ORWPT2  ; VOE//GT/GOW REV - Patient Lookup Functions ;8/13/07  17:45
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18         ;
    19         ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06
    20         ;GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP
    21         ; Ref. to ^UTILITY via IA 10061
    22         ;
    23         Q
    24         ;VWVOEDPT ;GFT  VOE PATIENT LOOKUP;6OCT2006
    25         ;;5.3;Registration;VWVF VOE LOCAL
    26         ;
    27         ;;Q
    28         ;
    29 LOOKUP(LST,X1)  ;'GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP
    30         K LST
    31         N GFTI,I,X,ILEN,IEN2,IENN,TAB,ILENP,X3,IEND,CR,XX
    32         N IRET
    33         N IDTMP,AJJTMP,AJJTMP1
    34         ;
    35         S X=X1
    36         I X="" Q
    37         S IEND=0
    38         ;UPPERCASE IT
    39         X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
    40         S ILEN=$L(X)
    41         ;CHECK INPUT  TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS
    42         ;CHECK FOR INITITAL LOOKUP BY DFN AS !DFN
    43         ;CHECK FOR LOOKUP BY DFN AS 3 TAB POSITION FOR CLICKING AFTER PREVIOUS LOOKUP
    44         S TAB=$C(9)
    45         S X3=$P(X,TAB,3)
    46         I X3'="",X3'="OPT" D
    47         .S X=X3
    48         .S ILENP=$L(X)
    49         .S X=$E(X,2,ILENP) ;TAKEOUT !
    50         .S U="^",(GFTI,I)=0
    51         .D LISTPOPD(X)
    52         .S IEND=1
    53         E  D
    54         .S X=$P(X,TAB,1)
    55         I IEND=1 Q
    56         I $E(X1,1,1)="'" D
    57         .I ILEN'=1 S X=$E(X1,2,ILEN)
    58         .;CHECK FOR ENDING "'"
    59         .S CR=$C(13)
    60         .I $E(X1,ILEN,ILEN)'="'" S IEND=1
    61         .S X=$P(X,"'",1)
    62         S U="^",(GFTI,I)=0
    63         I IEND=1 Q
    64         S XX=X    ; NO CR FOR HRN
    65         F  S IRET=$$CHKX(X) Q:IRET'=1  S I=$O(^AUPNPAT("D",X,I)) Q:'I  I X=$$HRN^DGLBPID(I) D LISTPOPH(I)  ;I X=$P($$HRN^DGLBPID(I),"#",2
    66         Q:GFTI
    67         ;
    68         S X=XX
    69         ;NOW CHECK FOR B CROSS REFERENCE
    70         D FIND^DIC(2,,,"MPC",X,,"B") ; ^SSN^BS5")
    71         F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  D LISTPOPB(+^(I,0))
    72         K ^TMP("DILIST",$J)
    73         Q:GFTI>0
    74 OVETT   ;
    75         Q:ILEN<4  ;USE ADOB LOOKUP XXX-
    76         ;
    77         ;
    78         ;
    79         ; NEW EDITS/GOW 8/12/07 BELOW. CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER
    80         ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM)
    81         ; WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56, JUN 12,68, ETC OR 4 DIGIT YEAR FOR EXPLICIT YEAR ENTRY, IE JUNE 1,1903
    82         S NOCONTIN=0
    83         D
    84         .S NOCONTIN=1
    85         .S IDTMP=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30)
    86         .I IDTMP'=X D
    87         ..S AJJTMP=$L($TR($P(X,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q    ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE
    88         ..S AJJTMP=$L($TR($P(X," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q     ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4  digit yr)
    89         .I IDTMP'=X Q    ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY
    90         .S AJJTMP=$L($TR($P(X,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0      ;NUMERIC INPUT
    91         .S AJJTMP=$L($TR($P(X,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
    92         .S AJJTMP=$L($TR($P(X,".",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
    93         I NOCONTIN=1 G TRYPH  ; TRY PHONE #
    94         ;END EDITS/GOW
    95         ;
    96         ;
    97         D FIND^DIC(2,,,"MPC",X,,"ADOB^B") ;^SSN^BS5")
    98         F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  D LISTPOP(+^(I,0),X1)
    99         K ^TMP("DILIST",$J)
    100         Q:GFTI>0
    101         ;TRY PHONE # WITH TRANSLATE
    102 TRYPH   ;
    103         Q:ILEN<10
    104         S X=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
    105         D FIND^DIC(2,,,"MPC",X,,"AZVWVOE^B") ;^SSN^BS5")
    106         F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  D LISTPOPP(+^(I,0),X1)
    107         K ^TMP("DILIST",$J)
    108         Q
    109 CHKX(X) ;CHECK TO SEE IF LEGITIMATE HRN EXISTS FOR IHS PATIENT HRN
    110         N IDX,ILENM1,IFLAG
    111         S IFLAG=0
    112         S IDX=X
    113         ;TO SEE blank char inserts
    114         S ILENM1=$L(X)-1
    115         I ILENM1>0 D
    116         .S IDX=$E(X,1,ILENM1)
    117         E  D
    118         .S IDX=""
    119         F  S IDX=$O(^AUPNPAT("D",IDX)) Q:(IDX="")!(IFLAG=1)  D
    120         . I IDX=X S IFLAG=1
    121         Q IFLAG
    122 CHKXB(X1)       ;CHECK TO SEE IF PATIENT NAME ENTERED TO ALLOW LOOKUP EVEN FOR SENSITIVE PATIENT
    123         N IDX,ILENM1,IFLAG,X
    124         S IFLAG=0
    125         S X=X1
    126         ;CONVERT UPPER CASE
    127         X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
    128         S IDX=X
    129         ;TO SEE blank char inserts
    130         S ILENM1=$L(X)-1
    131         I ILENM1>0 D
    132         .S IDX=$E(X,1,ILENM1)
    133         E  D
    134         .S IDX=""
    135         F  S IDX=$O(^DPT("B",IDX)) Q:(IDX="")!(IFLAG=1)  D
    136         . I IDX=X S IFLAG=1
    137         Q IFLAG
    138 LISTPOPB(DFN)   ;PATIENT NAME B X-REF
    139         N IEN
    140         N HRN,PHONE,X
    141         Q:($$SCREEN^DPTLK1(DFN))  ;SCREEN FOR VIP
    142         Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
    143         S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
    144         S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
    145         Q
    146 LISTPOP(DFN,X1) ;DOB
    147         N IEN
    148         N HRN,PHONE,X
    149         S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK
    150         Q:($$SCREEN^DPTLK1(DFN))&(IEN=0)  ;SCREEN FOR VIP
    151         Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
    152         S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
    153         S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
    154         Q
    155 LISTPOPP(DFN,X1)        ;PHONE #
    156         N IEN
    157         N HRN,PHONE,X
    158         S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK
    159         Q:($$SCREEN^DPTLK1(DFN))&(IEN=0)  ;SCREEN FOR VIP
    160         Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
    161         S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
    162         S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_PHONE_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
    163         Q
    164         ;
    165 LISTPOPH(DFN)   ;Q:$$SCREEN^DPTLK1(DFN)  ;SCREEN FOR VIP FOR HRN
    166         N HRN,PHONE
    167         Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
    168         S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
    169         S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_"'"_HRN_"'"_TAB_"!"_DFN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
    170         Q
    171 LISTPOPD(DFN)   ;
    172         N IEN
    173         N HRN,PHONE,X
    174         ;NO SCREEN FOR VIP
    175         Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
    176         S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
    177         S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
    178         Q
    179         ;
    180 VWPT1   ;VWPT NEW LOGIC . 4TH PIECE BELOW REPLACE $P(X,U,9)=SSN WITH ID AS $$ID^DGLBPID(DFN)
    181         ; THEN IF THIS VALUE = HRN AND BOTH '="" THEN PUT SINGLE QUOTES
    182         ; AROUND 4TH PIECE AS THIS IS SAME AS HRN.
    183         S ID=$$ID^DGLBPID(DFN) S HRN=$$HRN^DGLBPID(DFN)
    184         I (ID=HRN)&(HRN'="") S ID="'"_ID_"'"
    185         ;
    186         ;VWPT LINE BELOW WITH ID SUBSTITUTED FOR 9TH PIECE OF X
    187         S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_ID_U_U_$G(^(.1))_U_$G(^(.101))
    188         ; End VOE mod
    189         ;
    190         ; Following taken from ORWPT call to VWPT1 to save space
    191         ;
    192         S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
    193         S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
    194         S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
    195         S:'$D(IOST) IOST="P-OTHER"
    196         S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1)
    197         D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
    198         I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
    199         Q
    200 VWPT2   ;VWPT  GET HRN AND ALTERNATE HRN
    201         S $P(REC,U,17)="'"_$$HRN^DGLBPID(DFN)_"'" ;$$HRN^VWVOEDPT(DFN)
    202         S $P(REC,U,18)=$$ALTHRN(DFN)
    203         K VAEL,VAERR ;VADPT call to kill?
    204         S ^DISV(DUZ,"^DPT(")=DFN
    205         Q
    206 ALTHRN(DFN)     ;
    207         Q ""
     1ORWPT2 ; VOE//GT/GOW REV - Patient Lookup Functions ;8/13/07  17:45
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;
     19 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06
     20 ;GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP
     21 ; Ref. to ^UTILITY via IA 10061
     22 ;
     23 Q
     24 ;VWVOEDPT ;GFT  VOE PATIENT LOOKUP;6OCT2006
     25 ;;5.3;Registration;VWVF VOE LOCAL
     26 ;
     27 ;;Q
     28 ;
     29LOOKUP(LST,X1) ;'GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP
     30 K LST
     31 N GFTI,I,X,ILEN,IEN2,IENN,TAB,ILENP,X3,IEND,CR,XX
     32 N IRET
     33 N IDTMP,AJJTMP,AJJTMP1
     34 ;
     35 S X=X1
     36 I X="" Q
     37 S IEND=0
     38 ;UPPERCASE IT
     39 X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
     40 S ILEN=$L(X)
     41 ;CHECK INPUT  TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS
     42 ;CHECK FOR INITITAL LOOKUP BY DFN AS !DFN
     43 ;CHECK FOR LOOKUP BY DFN AS 3 TAB POSITION FOR CLICKING AFTER PREVIOUS LOOKUP
     44 S TAB=$C(9)
     45 S X3=$P(X,TAB,3)
     46 I X3'="",X3'="OPT" D
     47 .S X=X3
     48 .S ILENP=$L(X)
     49 .S X=$E(X,2,ILENP) ;TAKEOUT !
     50 .S U="^",(GFTI,I)=0
     51 .D LISTPOPD(X)
     52 .S IEND=1
     53 E  D
     54 .S X=$P(X,TAB,1)
     55 I IEND=1 Q
     56 I $E(X1,1,1)="'" D
     57 .I ILEN'=1 S X=$E(X1,2,ILEN)
     58 .;CHECK FOR ENDING "'"
     59 .S CR=$C(13)
     60 .I $E(X1,ILEN,ILEN)'="'" S IEND=1
     61 .S X=$P(X,"'",1)
     62 S U="^",(GFTI,I)=0
     63 I IEND=1 Q
     64 S XX=X    ; NO CR FOR HRN
     65 F  S IRET=$$CHKX(X) Q:IRET'=1  S I=$O(^AUPNPAT("D",X,I)) Q:'I  I X=$$HRN^DGLBPID(I) D LISTPOPH(I)  ;I X=$P($$HRN^DGLBPID(I),"#",2
     66 Q:GFTI
     67 ;
     68 S X=XX
     69 ;NOW CHECK FOR B CROSS REFERENCE
     70 D FIND^DIC(2,,,"MPC",X,,"B") ; ^SSN^BS5")
     71 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  D LISTPOPB(+^(I,0))
     72 K ^TMP("DILIST",$J)
     73 Q:GFTI>0
     74OVETT ;
     75 Q:ILEN<4  ;USE ADOB LOOKUP XXX-
     76 ;
     77 ;
     78 ;
     79 ; NEW EDITS/GOW 8/12/07 BELOW. CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER
     80 ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM)
     81 ; WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56, JUN 12,68, ETC OR 4 DIGIT YEAR FOR EXPLICIT YEAR ENTRY, IE JUNE 1,1903
     82 S NOCONTIN=0
     83 D
     84 .S NOCONTIN=1
     85 .S IDTMP=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30)
     86 .I IDTMP'=X D
     87 ..S AJJTMP=$L($TR($P(X,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q    ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE
     88 ..S AJJTMP=$L($TR($P(X," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q     ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4  digit yr)
     89 .I IDTMP'=X Q    ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY
     90 .S AJJTMP=$L($TR($P(X,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0      ;NUMERIC INPUT
     91 .S AJJTMP=$L($TR($P(X,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
     92 .S AJJTMP=$L($TR($P(X,".",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
     93 I NOCONTIN=1 G TRYPH  ; TRY PHONE #
     94 ;END EDITS/GOW
     95 ;
     96 ;
     97 D FIND^DIC(2,,,"MPC",X,,"ADOB^B") ;^SSN^BS5")
     98 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  D LISTPOP(+^(I,0),X1)
     99 K ^TMP("DILIST",$J)
     100 Q:GFTI>0
     101 ;TRY PHONE # WITH TRANSLATE
     102TRYPH ;
     103 Q:ILEN<10
     104 S X=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
     105 D FIND^DIC(2,,,"MPC",X,,"AZVWVOE^B") ;^SSN^BS5")
     106 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  D LISTPOPP(+^(I,0),X1)
     107 K ^TMP("DILIST",$J)
     108 Q
     109CHKX(X) ;CHECK TO SEE IF LEGITIMATE HRN EXISTS FOR IHS PATIENT HRN
     110 N IDX,ILENM1,IFLAG
     111 S IFLAG=0
     112 S IDX=X
     113 ;TO SEE blank char inserts
     114 S ILENM1=$L(X)-1
     115 I ILENM1>0 D
     116  .S IDX=$E(X,1,ILENM1)
     117 E  D
     118 .S IDX=""
     119 F  S IDX=$O(^AUPNPAT("D",IDX)) Q:(IDX="")!(IFLAG=1)  D
     120 . I IDX=X S IFLAG=1
     121 Q IFLAG
     122CHKXB(X1) ;CHECK TO SEE IF PATIENT NAME ENTERED TO ALLOW LOOKUP EVEN FOR SENSITIVE PATIENT
     123 N IDX,ILENM1,IFLAG,X
     124 S IFLAG=0
     125 S X=X1
     126 ;CONVERT UPPER CASE
     127 X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
     128 S IDX=X
     129 ;TO SEE blank char inserts
     130 S ILENM1=$L(X)-1
     131 I ILENM1>0 D
     132  .S IDX=$E(X,1,ILENM1)
     133 E  D
     134 .S IDX=""
     135 F  S IDX=$O(^DPT("B",IDX)) Q:(IDX="")!(IFLAG=1)  D
     136 . I IDX=X S IFLAG=1
     137 Q IFLAG
     138LISTPOPB(DFN) ;PATIENT NAME B X-REF
     139 N IEN
     140 N HRN,PHONE,X
     141 Q:($$SCREEN^DPTLK1(DFN))  ;SCREEN FOR VIP
     142 Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
     143 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
     144 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
     145 Q
     146LISTPOP(DFN,X1) ;DOB
     147 N IEN
     148 N HRN,PHONE,X
     149 S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK
     150 Q:($$SCREEN^DPTLK1(DFN))&(IEN=0)  ;SCREEN FOR VIP
     151 Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
     152 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
     153 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
     154 Q
     155LISTPOPP(DFN,X1) ;PHONE #
     156 N IEN
     157 N HRN,PHONE,X
     158 S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK
     159 Q:($$SCREEN^DPTLK1(DFN))&(IEN=0)  ;SCREEN FOR VIP
     160 Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
     161 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
     162 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_PHONE_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
     163 Q
     164 ;
     165LISTPOPH(DFN) ;Q:$$SCREEN^DPTLK1(DFN)  ;SCREEN FOR VIP FOR HRN
     166 N HRN,PHONE
     167 Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
     168 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
     169 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_"'"_HRN_"'"_TAB_"!"_DFN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
     170 Q
     171LISTPOPD(DFN) ;
     172 N IEN
     173 N HRN,PHONE,X
     174 ;NO SCREEN FOR VIP
     175 Q:GFTI=-1  I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
     176 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
     177 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
     178 Q
     179 ;
     180VWPT1 ;VWPT NEW LOGIC . 4TH PIECE BELOW REPLACE $P(X,U,9)=SSN WITH ID AS $$ID^DGLBPID(DFN)
     181 ; THEN IF THIS VALUE = HRN AND BOTH '="" THEN PUT SINGLE QUOTES
     182 ; AROUND 4TH PIECE AS THIS IS SAME AS HRN.
     183 S ID=$$ID^DGLBPID(DFN) S HRN=$$HRN^DGLBPID(DFN)
     184 I (ID=HRN)&(HRN'="") S ID="'"_ID_"'"
     185 ;
     186 ;VWPT LINE BELOW WITH ID SUBSTITUTED FOR 9TH PIECE OF X
     187 S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_ID_U_U_$G(^(.1))_U_$G(^(.101))
     188 ; End VOE mod
     189 ;
     190 ; Following taken from ORWPT call to VWPT1 to save space
     191 ;
     192 S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
     193 S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
     194 S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
     195 S:'$D(IOST) IOST="P-OTHER"
     196 S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1)
     197 D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
     198 I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
     199 Q
     200VWPT2 ;VWPT  GET HRN AND ALTERNATE HRN
     201 S $P(REC,U,17)="'"_$$HRN^DGLBPID(DFN)_"'" ;$$HRN^VWVOEDPT(DFN)
     202 S $P(REC,U,18)=$$ALTHRN(DFN)
     203 K VAEL,VAERR ;VADPT call to kill?
     204 S ^DISV(DUZ,"^DPT(")=DFN
     205 Q
     206ALTHRN(DFN) ;
     207 Q ""

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m

    r613 r623  
    1 ORWPT3  ; VOE/GOW /REV - Patient Lookup Functions ;8/13/07  17:49
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18         ;'Modified' MAS Patient Look-up Check Cross-References June 1987
    19         ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED WITH "OTHER" RADIOBUTTON LOOKUPS FOR DOB AND PHONE NO 11/14/06
    20         ;
    21         ; Ref. to ^UTILITY via IA 10061
    22         ;
    23         Q
    24         ;
    25         ;VWPT ENHANCEMENTS folow for "other" RADIO BUTTONlookup
    26 OTHER(LST,IDIN,OTHER)   ; RADIO BUTTON Return a list of patients matching other ID identifier
    27         N I,ID,IEN,ILENX,XREF,IDM1,ILEN1,ILNM1,ILENM1,IDD1,IPAST1,IDXX,IDSS,IDD2,LEN1,IFDN,IDX,IDS,DATEF,ILEN1,IPAST,ZVW,TEMP,IVAL,IVAR1,IFIND,IFDNS,IVAR,ARRAY,ERRARRAY,IENS
    28         N IEN2,IENN,TAB,IX
    29         N ILENP,X3,IEND,IDXS,IENNNN
    30         N IDTMP,AJJTMP,AJJTMP1
    31         I IDIN="" Q
    32         S (I,IEN,IEND)=0
    33         S ID=IDIN
    34         S X=ID
    35         S ILENX=$L(X)
    36         ;REMOVES TABS
    37         ;CHECK INPUT  TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS
    38         S TAB=$C(9)
    39         S IX=$P(X,TAB,3) ; WAS 2ND POS
    40         I IX'="" D
    41         .S ILENP=$L(IX)
    42         .S X=$E(IX,2,ILENP) ; JUMP OVER !
    43         .S LST(1)=X_U_$P(^DPT(X,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_X_U_$$ID^DGLBPID(X) ; $$SSN^DPTLK1_U_IVAL  ; RETURN OTHER AS 5TH PIECE
    44         .;
    45         .S IEND=1
    46         E  D
    47         .;JUST UPPER CASE IT
    48         .;UPPERCASE IT
    49         .X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
    50         I IEND=1 Q
    51         S ID=X
    52         ;OTHER IS FIELD NAME
    53         ;GET THE FIELD NUMBER
    54         S IFDN=0
    55         S IFDN=$O(^DD(2,"B",OTHER,IFDN))
    56         I IFDN="" Q
    57         ;FOR NOW JUST USE ONE OF TWO CROSS-REFERENCES ,
    58         ;ONE FOR DOB AS ADOB AND THE OTHER FOR PHONE # AS AZVWVOE
    59         I OTHER="DATE OF BIRTH" S ICREF="ADOB"
    60         I OTHER="PHONE NUMBER [RESIDENCE]" D
    61         .S ICREF="AZVWVOE"
    62         .S ID=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
    63         I ICREF="AZVWVOE" I ILENX<7 Q
    64         ;
    65         ; NEW EDITS/GOW 8/12/07 BELOW. RADIO BUTTON HAS SLIGHTLY DIFFERENT FUNCTIONALITY THAN
    66         ; WITH GENERIC MULTI-SOURCE LOOKUP. ALSO, CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER
    67         ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM)
    68         ; THE LOGIC ALLOWED A FUZZY MONTH ONLY LOOKUP FOR DOB AS A SPECIFIC DOB MAY NOT BE KNOWN ,OR REMEMBERED.
    69         ; FOR FUZZY LOGIC REQUIRE 4 DIGIT YEAR ON DATE RANGE W/O SPECIFIC DAY(DATE) ENTERED
    70         ; EXAMPLE, AS MONTH/YEAR ( IE, JUN 2005). NOW, MAKE CHANGE TO ALLOW THIS ONLY BY APHABETIC MONTH AND NUMERIC YEAR (2 OR 4 DIGIT) LOOKUP
    71         ; THEN FOR SPECIFIC DOB LOOKUP WITH RADIO BUTTON SELECTION, WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56
    72         ; FOR WHICH WAIT FOR SELECTION WILL OCCUR UNTIL AT A TRAILING 2 DIGIT YEAR IS INPUT WITH THE FORMER FORMATS ABOVE
    73         S NOCONTIN=0
    74         I ICREF="ADOB" D
    75         .S NOCONTIN=1
    76         .S IDTMP=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30)
    77         .I IDTMP'=ID D
    78         ..;ALPHABETIC FUZZY MONTH ALLOWED or a specific date for at least a 4 DIGIT year that must specified after a "," ( ie June 15,1968)
    79         ..;OTHERWISE CHECK FOR TRAILING YEAR
    80         ..S AJJTMP=$L($TR($P(ID,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q    ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE
    81         ..S AJJTMP=$L($TR($P(ID," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q     ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4  digit yr)
    82         ..S AJJTMP=$L($TR($P(ID," ",2)," ")) I AJJTMP>3 S AJJTMP1=$TR(AJJTMP,",") I AJJTMP1=AJJTMP S NOCONTIN=0 Q     ;CASE FOR FUZZY DATE ( MONTH followed by " " (space) and Year (4  digit yr)
    83         .I IDTMP'=ID Q    ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY
    84         .S AJJTMP=$L($TR($P(ID,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0      ;NUMERIC INPUT
    85         .S AJJTMP=$L($TR($P(ID,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
    86         .S AJJTMP=$L($TR($P(ID,".",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
    87         I NOCONTIN=1 Q
    88         ;END EDITS/GOW
    89         ;
    90         S IDX=ID
    91         ;TO SEE blank char inserts
    92         S ILENM1=$L(ID)-1
    93         I ILENM1>0 D
    94         .;S IDLC=$E(ID,1,ILENM1)
    95         .S IDX=$E(ID,1,ILENM1) S IDXS=IDX
    96         E  D
    97         .S IDX="" S IDXS=IDX
    98         Q:ILENX<4  ;USE PHONE NUMBER LOOKUP XXX-
    99         ;HOWEVER ID DATE OR DATE/TIME FIELD CONVERT ID TO
    100         ;INTERNAL TIME
    101         S DATEF=$P($G(^DD(2,IFDN,0)),"^",2)
    102         I DATEF["D" D
    103         .;NEW BELOW
    104         .S X=ID D ^%DT S IDX=Y S IDS=Y
    105         .I Y'=-1 D
    106         . . S ILNM1=$L(IDX)-1
    107         . . S IDX=$E(IDX,1,ILNM1)
    108         . . ;W !,"IDX=",IDX,"IDS=",IDS
    109         S IPAST=0
    110         S IPAST1=0
    111         S ILEN1=$L(ID)
    112         F  S IDX=$O(^DPT(ICREF,IDX)) Q:(IDX="")!(IPAST1=1)  D
    113         . S IEN=0
    114         . ;EXTRA TO GET TRAILING SPACES
    115         . I DATEF'["D" D
    116         . . S IDD1=$E(IDX,1,ILEN1) I $L(IDD1)<ILEN1 Q
    117         . F  S IEN=$O(^DPT(ICREF,IDX,IEN)) Q:IEN=""  D
    118         . . S IPAST=0
    119         . . ;W !,"IDX=",IDX," IDS=",IDS
    120         . .I DATEF["D" D
    121         . . .;CHECK FOR MONTH ONLY
    122         . . .I $E(IDS,6,7)="00" D
    123         . . . .S IDXX=$E(IDX,1,5) S IDSS=$E(IDS,1,5)
    124         . . . .;W !,"IDXX=",IDXX," IDSS=",IDSS
    125         . . . .I IDXX'=IDSS S IPAST=1
    126         . . . .I IDXX>IDSS S IPAST1=1 Q
    127         . . . .I IPAST=1 Q
    128         . . .E  D
    129         . . . .;W !,"IDX=",IDX
    130         . . . .I IDX'=IDS S IPAST=1
    131         . . . .I IDX>IDS S IPAST1=1 Q
    132         . . . .I IPAST=1 Q
    133         . .E  D
    134         . . .S IDD1=$E(IDX,1,ILEN1) S IDD2=$E(ID,1,ILEN1)
    135         . . .;W !,"IDD1=",IDD1 W !,"IDD2=",IDD2
    136         . . .I $$ISNUM(IDD2)&$$ISNUM(IDD1) D
    137         . . . .I IDD1'=IDD2 S IPAST=1
    138         . . . .I IDD1>IDD2 S IPAST1=1 Q
    139         . . . .I IPAST=1 Q
    140         . . . .;
    141         . . . .;
    142         . . .E  D
    143         . . . .;
    144         . . . .I IDD1'=IDD2 S IPAST=1
    145         . . . .I IDD1]IDD2 S IPAST1=1 Q
    146         . . . .I IPAST=1 Q
    147         . .I IPAST=1 Q
    148         . .I DATEF["D" D
    149         . . .S Y=IDX S X=IDX D DD^%DT S IVAL=Y
    150         . .E  D
    151         . . .S IVAL=IDX
    152         . .S I=I+1
    153         . .I $$SCREEN^DPTLK1(IEN) Q
    154         . .;IVAL IS NOT HRN NOW
    155         . .S LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_IVAL_TAB_"!"_IEN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(IEN) ; _U_IVAL  ; RETURN OTHER AS 5TH PIECE
    156         Q
    157 ISNUM(XA)       ;
    158         I XA=+XA Q 1
    159         Q 0
     1ORWPT3 ; VOE/GOW /REV - Patient Lookup Functions ;8/13/07  17:49
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
     19 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED WITH "OTHER" RADIOBUTTON LOOKUPS FOR DOB AND PHONE NO 11/14/06
     20 ;
     21 ; Ref. to ^UTILITY via IA 10061
     22 ;
     23 Q
     24 ;
     25 ;VWPT ENHANCEMENTS folow for "other" RADIO BUTTONlookup
     26OTHER(LST,IDIN,OTHER) ; RADIO BUTTON Return a list of patients matching other ID identifier
     27 N I,ID,IEN,ILENX,XREF,IDM1,ILEN1,ILNM1,ILENM1,IDD1,IPAST1,IDXX,IDSS,IDD2,LEN1,IFDN,IDX,IDS,DATEF,ILEN1,IPAST,ZVW,TEMP,IVAL,IVAR1,IFIND,IFDNS,IVAR,ARRAY,ERRARRAY,IENS
     28 N IEN2,IENN,TAB,IX
     29 N ILENP,X3,IEND,IDXS,IENNNN
     30 N IDTMP,AJJTMP,AJJTMP1
     31 I IDIN="" Q
     32 S (I,IEN,IEND)=0
     33 S ID=IDIN
     34 S X=ID
     35 S ILENX=$L(X)
     36 ;REMOVES TABS
     37 ;CHECK INPUT  TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS
     38 S TAB=$C(9)
     39 S IX=$P(X,TAB,3) ; WAS 2ND POS
     40 I IX'="" D
     41 .S ILENP=$L(IX)
     42 .S X=$E(IX,2,ILENP) ; JUMP OVER !
     43 .S LST(1)=X_U_$P(^DPT(X,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_X_U_$$ID^DGLBPID(X) ; $$SSN^DPTLK1_U_IVAL  ; RETURN OTHER AS 5TH PIECE
     44 .;
     45 .S IEND=1
     46 E  D
     47 .;JUST UPPER CASE IT
     48 .;UPPERCASE IT
     49 .X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
     50 I IEND=1 Q
     51 S ID=X
     52 ;OTHER IS FIELD NAME
     53 ;GET THE FIELD NUMBER
     54 S IFDN=0
     55 S IFDN=$O(^DD(2,"B",OTHER,IFDN))
     56 I IFDN="" Q
     57 ;FOR NOW JUST USE ONE OF TWO CROSS-REFERENCES ,
     58 ;ONE FOR DOB AS ADOB AND THE OTHER FOR PHONE # AS AZVWVOE
     59 I OTHER="DATE OF BIRTH" S ICREF="ADOB"
     60 I OTHER="PHONE NUMBER [RESIDENCE]" D
     61 .S ICREF="AZVWVOE"
     62 .S ID=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
     63 I ICREF="AZVWVOE" I ILENX<7 Q
     64 ;
     65 ; NEW EDITS/GOW 8/12/07 BELOW. RADIO BUTTON HAS SLIGHTLY DIFFERENT FUNCTIONALITY THAN
     66 ; WITH GENERIC MULTI-SOURCE LOOKUP. ALSO, CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER
     67 ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM)
     68 ; THE LOGIC ALLOWED A FUZZY MONTH ONLY LOOKUP FOR DOB AS A SPECIFIC DOB MAY NOT BE KNOWN ,OR REMEMBERED.
     69 ; FOR FUZZY LOGIC REQUIRE 4 DIGIT YEAR ON DATE RANGE W/O SPECIFIC DAY(DATE) ENTERED
     70 ; EXAMPLE, AS MONTH/YEAR ( IE, JUN 2005). NOW, MAKE CHANGE TO ALLOW THIS ONLY BY APHABETIC MONTH AND NUMERIC YEAR (2 OR 4 DIGIT) LOOKUP
     71 ; THEN FOR SPECIFIC DOB LOOKUP WITH RADIO BUTTON SELECTION, WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56
     72 ; FOR WHICH WAIT FOR SELECTION WILL OCCUR UNTIL AT A TRAILING 2 DIGIT YEAR IS INPUT WITH THE FORMER FORMATS ABOVE
     73 S NOCONTIN=0
     74 I ICREF="ADOB" D
     75 .S NOCONTIN=1
     76 .S IDTMP=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30)
     77 .I IDTMP'=ID D
     78 ..;ALPHABETIC FUZZY MONTH ALLOWED or a specific date for at least a 4 DIGIT year that must specified after a "," ( ie June 15,1968)
     79 ..;OTHERWISE CHECK FOR TRAILING YEAR
     80 ..S AJJTMP=$L($TR($P(ID,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q    ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE
     81 ..S AJJTMP=$L($TR($P(ID," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q     ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4  digit yr)
     82 ..S AJJTMP=$L($TR($P(ID," ",2)," ")) I AJJTMP>3 S AJJTMP1=$TR(AJJTMP,",") I AJJTMP1=AJJTMP S NOCONTIN=0 Q     ;CASE FOR FUZZY DATE ( MONTH followed by " " (space) and Year (4  digit yr)
     83 .I IDTMP'=ID Q    ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY
     84 .S AJJTMP=$L($TR($P(ID,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0      ;NUMERIC INPUT
     85 .S AJJTMP=$L($TR($P(ID,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
     86 .S AJJTMP=$L($TR($P(ID,".",3)," ")) I AJJTMP>1 S NOCONTIN=0      ; NUMERIC INPUT
     87 I NOCONTIN=1 Q
     88 ;END EDITS/GOW
     89 ;
     90 S IDX=ID
     91 ;TO SEE blank char inserts
     92 S ILENM1=$L(ID)-1
     93 I ILENM1>0 D
     94 .;S IDLC=$E(ID,1,ILENM1)
     95 .S IDX=$E(ID,1,ILENM1) S IDXS=IDX
     96 E  D
     97 .S IDX="" S IDXS=IDX
     98 Q:ILENX<4  ;USE PHONE NUMBER LOOKUP XXX-
     99 ;HOWEVER ID DATE OR DATE/TIME FIELD CONVERT ID TO
     100 ;INTERNAL TIME
     101 S DATEF=$P($G(^DD(2,IFDN,0)),"^",2)
     102 I DATEF["D" D
     103 .;NEW BELOW
     104 .S X=ID D ^%DT S IDX=Y S IDS=Y
     105 .I Y'=-1 D
     106 . . S ILNM1=$L(IDX)-1
     107 . . S IDX=$E(IDX,1,ILNM1)
     108 . . ;W !,"IDX=",IDX,"IDS=",IDS
     109 S IPAST=0
     110 S IPAST1=0
     111 S ILEN1=$L(ID)
     112 F  S IDX=$O(^DPT(ICREF,IDX)) Q:(IDX="")!(IPAST1=1)  D
     113 . S IEN=0
     114 . ;EXTRA TO GET TRAILING SPACES
     115 . I DATEF'["D" D
     116 . . S IDD1=$E(IDX,1,ILEN1) I $L(IDD1)<ILEN1 Q
     117 . F  S IEN=$O(^DPT(ICREF,IDX,IEN)) Q:IEN=""  D
     118 . . S IPAST=0
     119 . . ;W !,"IDX=",IDX," IDS=",IDS
     120 . .I DATEF["D" D
     121 . . .;CHECK FOR MONTH ONLY
     122 . . .I $E(IDS,6,7)="00" D
     123 . . . .S IDXX=$E(IDX,1,5) S IDSS=$E(IDS,1,5)
     124 . . . .;W !,"IDXX=",IDXX," IDSS=",IDSS
     125 . . . .I IDXX'=IDSS S IPAST=1
     126 . . . .I IDXX>IDSS S IPAST1=1 Q
     127 . . . .I IPAST=1 Q
     128 . . .E  D
     129 . . . .;W !,"IDX=",IDX
     130 . . . .I IDX'=IDS S IPAST=1
     131 . . . .I IDX>IDS S IPAST1=1 Q
     132 . . . .I IPAST=1 Q
     133 . .E  D
     134 . . .S IDD1=$E(IDX,1,ILEN1) S IDD2=$E(ID,1,ILEN1)
     135 . . .;W !,"IDD1=",IDD1 W !,"IDD2=",IDD2
     136 . . .I $$ISNUM(IDD2)&$$ISNUM(IDD1) D
     137 . . . .I IDD1'=IDD2 S IPAST=1
     138 . . . .I IDD1>IDD2 S IPAST1=1 Q
     139 . . . .I IPAST=1 Q
     140 . . . .;
     141 . . . .;
     142 . . .E  D
     143 . . . .;
     144 . . . .I IDD1'=IDD2 S IPAST=1
     145 . . . .I IDD1]IDD2 S IPAST1=1 Q
     146 . . . .I IPAST=1 Q
     147 . .I IPAST=1 Q
     148 . .I DATEF["D" D
     149 . . .S Y=IDX S X=IDX D DD^%DT S IVAL=Y
     150 . .E  D
     151 . . .S IVAL=IDX
     152 . .S I=I+1
     153 . .I $$SCREEN^DPTLK1(IEN) Q
     154 . .;IVAL IS NOT HRN NOW
     155 . .S LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_IVAL_TAB_"!"_IEN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(IEN) ; _U_IVAL  ; RETURN OTHER AS 5TH PIECE
     156 Q
     157ISNUM(XA) ;
     158 I XA=+XA Q 1
     159 Q 0

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP.m

    r613 r623  
    1 ORWRP   ; ALB/MJK,dcm Report Calls ; 12/05/02 11:03
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262,243**;Dec 17, 1997;Build 242
    3         ;
    4 LABLIST(LST)    ; -- report list for labs tab
    5         ;  RPC: ORWRP LAB REPORT LIST
    6         N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD
    7         S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0
    8         D SETITEM(ROOT,"[LAB REPORT LIST]")
    9         D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST")
    10         F  S I=$O(ORLIST(I)) Q:'I  Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  S X0=^(0),X2=$G(^(2)) D
    11         . Q:$P(X0,"^",12)="L"
    12         . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
    13         . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
    14         . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
    15         . D SETITEM(.ROOT,X)
    16         D SETITEM(.ROOT,"$$END")
    17         Q
    18 LIST(LST)       ; -- report lists for reports tab
    19         ;  RPC: ORWRP REPORT LIST
    20         N EOF,ROOT
    21         S EOF="$$END",ROOT=$NA(LST)
    22         K @ROOT
    23         D GETRPTS(.ROOT,.EOF) ; -report list
    24         D GETHS(.ROOT,.EOF) ; -health summary types
    25         D GETDT(.ROOT,.EOF) ; -date ranges
    26         Q
    27 GETCOL(ROOT,IFN)        ; -- get Column headers for ListView
    28         N I,J,X,VAL
    29         Q:'$G(IFN)
    30         S I=0,ROOT=$NA(ROOT)
    31         F  S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I  D
    32         . S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0
    33         . F  S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J  I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D
    34         .. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I)
    35         .. D SETITEM(.ROOT,X)
    36         Q
    37 GETRPTS(ROOT,EOF)       ; -- get report list
    38         N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD
    39         D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST")
    40         S (CNT,I)=0
    41         F  S I=$O(ORLIST(I)) Q:'I  Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  S X0=^(0),X2=$G(^(2)) D
    42         . Q:$P(X0,"^",12)="L"
    43         . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
    44         . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
    45         . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
    46         . D SETITEM(.ROOT,X)
    47         D SETITEM(.ROOT,"$$END")
    48         Q
    49 GETHS(ROOT,EOF) ; --get health summary types
    50         N C,I,IFN,ORHSPARM,ORERR,X,T
    51         K ^TMP("ORHSPARM",$J)
    52         S ORHSROOT="^TMP(""ORHSPARM"",$J)"
    53         I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D
    54         . F  S I=$O(^GMT(142,"B",I)) Q:I=""  S IFN=$O(^(I,0)) Q:'IFN  D
    55         .. S X=$G(^GMT(142,IFN,0)) Q:'$L(X)
    56         .. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1"
    57         .. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report"
    58         I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D
    59         . D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR)
    60         . Q:$G(ORERR)
    61         . S I=0 F  S I=$O(@ORHSROOT@(I)) Q:'I  S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report"
    62         D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
    63         S I=0  F  S I=$O(@ORHSROOT@(I)) Q:'I  D SETITEM(.ROOT,"h"_@ORHSROOT@(I))
    64         D SETITEM(.ROOT,EOF)
    65         Q
    66 GETDT(ROOT,EOF) ; -- get date range choices
    67         N I,X
    68         D SETITEM(.ROOT,"[DATE RANGES]")
    69         F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF  D SETITEM(.ROOT,"d"_X)
    70         Q
    71 DTLIST  ; -- list of date ranges
    72         ;<number of days>^ <display text>
    73         ;;S^Date Range...
    74         ;;0^Today
    75         ;;7^One Week Back
    76         ;;14^Two Weeks Back
    77         ;;30^One Month Back
    78         ;;180^Six Months Back
    79         ;;365^One Year Back
    80         ;;732^Two Years Back
    81         ;;50000^All Results
    82         ;;$$END
    83         ;
    84 SETITEM(ROOT,X) ; -- set item in list
    85         S @ROOT@($O(@ROOT@(9999),-1)+1)=X
    86         Q
    87 RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA)   ; -- return report text
    88         ;ROOT=Output in ^TMP("ORDATA",$J)
    89         ;DFN=Patient DFN ; ICN for remote sites
    90         ;RPTID=Unique report ID_";"_Remote ID_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc)
    91         ;HSTYPE=Health Sum Type
    92         ;DTRANGE=# days back from today
    93         ;EXAMID=Rad exam ID
    94         ;ALPHA=Start date
    95         ;OMEGA=End date
    96         ;  RPC: ORWRP REPORT TEXT
    97         ;
    98         N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT,TAB
    99         K ^TMP("ORDATA",$J)
    100         S TAB="R"
    101         I $E(RPTID,1,2)="L:" S TAB="L",RPTID=$P(RPTID,":",2,999) ;an ID beginning with "L:" forces TAB to LAB - "L:" added in GUI code
    102         S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":")
    103         I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls
    104         S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
    105         F  S I=$O(^ORD(101.24,"AC",I)) Q:I=""  S J=0 F  S J=$O(^ORD(101.24,"AC",I,J)) Q:'J  D
    106         . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)=TAB S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3)
    107         I '$L(X0) D NOTYET(.ROOT) Q
    108         S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6)
    109         I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q
    110         I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q
    111         ;I $G(ALPHA) S X=ALPHA-$G(OMEGA) D  ;jeh 243
    112         I $G(ALPHA) D
    113         . N X1,X2
    114         . S X=ALPHA
    115         . S X1=ALPHA,X2=$G(OMEGA) D:X2 ^%DTC ;X returned, # of days diff
    116         . I X<0 S X=X*(-1)
    117         . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE=""
    118         I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA=""
    119         I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959"
    120         I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959"
    121         S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE
    122         I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4)
    123         I $L($G(HSTYPE)) M ID=HSTYPE
    124         I $L($G(EXAMID)) M ID=EXAMID
    125         S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)"
    126         I REMOTE S GO=0 D  Q:'GO
    127         . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q
    128         . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN)
    129         . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q
    130         . S GO=+$P(X0,"^",3)
    131         . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")")
    132         S %ZIS="0N"
    133         D @OUT
    134         Q
    135 NOTYET(ROOT)    ; -- not available
    136         D SETITEM(.ROOT,"Report not available at this time.")
    137         Q
    138 START(RM,GOTO,ORIOSL)   ;
    139         ;RM=Right margin
    140         N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS
    141         S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP"
    142         D HFSOPEN(ORHANDLE,ORHFS,"W")
    143         I POP D  Q
    144         . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file")
    145         D IOVAR(.ORIO,.RM,.ORIOSL)
    146         N $ETRAP,$ESTACK
    147         S $ETRAP="D ERR^ORWRP Q"
    148         U IO
    149         D @GOTO
    150         D HFSCLOSE(ORHANDLE,ORHFS)
    151         Q
    152 ERR     ;Error trap
    153         S $ETRAP="D UNWIND^ORWRP Q"
    154         N %ZIS
    155         S %ZIS="0N"
    156         D @^%ZOSF("ERRTN") ;file error
    157         I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE)
    158         I $D(ORHFS) D
    159         . N ORARR,OROK
    160         . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file
    161         S $ECODE=",UOR69 error during CPRS report build,"
    162         Q
    163 UNWIND  ;Unwind Error stack
    164         Q:$ESTACK>1  ;pop stack
    165         ;
    166         Q
    167 HFS()   ; -- get hfs file name
    168         N H
    169         S H=$H
    170         Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT"
    171 HFSOPEN(HANDLE,ORHFS,ORMODE)    ;
    172         D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP
    173         Q
    174 IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT)      ;Setup IO variables based on IO Device
    175         N IFN,IFN1
    176         S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS")
    177         I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN
    178         I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^"))
    179         I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3))
    180         Q
    181 HFSCLOSE(HANDLE,ORHFS)  ;Close HFS and unload data
    182         N ORDEL,X,%ZIS
    183         S %ZIS="0N"
    184         I IO[ORHFS D CLOSE^%ZISH(HANDLE)
    185         S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)=""
    186         K @ROOT
    187         S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4)
    188         D STRIP
    189         S X=$$DEL^%ZISH(,$NA(ORDEL))
    190         Q
    191 USEHFS  ; -- use host file to build global array
    192         N OROK,SECTION
    193         S SECTION=0
    194         D INIT
    195         S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q
    196         D STRIP
    197         N ORARR S ORARR(ORHFS)=""
    198         S OROK=$$DEL^%ZISH("",$NA(ORARR))
    199         Q
    200 INIT    ; -- initialize counts and global section
    201         S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION))
    202         K @ROOT
    203         Q
    204 FINAL   ; -- set 'x of y' for each section CALLED FROM ^ORWLR
    205         N I
    206         F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION
    207         Q
    208 STRIP   ; -- strip off control chars
    209         N I,X
    210         S I=0 F  S I=$O(@ROOT@(I)) Q:'I  S X=^(I) D
    211         . I X[$C(8) D  ;BS
    212         .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q  ;BS & _
    213         .. S (X,@ROOT@(I))=$TR(X,$C(8),"")
    214         . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF
    215         Q
    216 WINDFLT(ORY)    ;Windows printer as default?
    217         S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT")
    218         Q
    219 GETDFPRT(Y,ORUSER,ORLOC)        ; Returns default printer for user
    220         N IEN,X0,ENT
    221         S ENT="ALL"
    222         I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC
    223         I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q
    224         S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0
    225         Q:'$D(^%ZIS(1,IEN,0))  S X0=^(0)
    226         S Y=IEN_";"_$P(X0,U)
    227         Q
    228 SAVDFPRT(Y,ORDEV)       ; Save new default printer for user
    229         N ORPAR,ORERR,ORWINDEF
    230         Q:$L(ORDEV)=0
    231         ; Reset Windows printer default to True/False
    232         S ORPAR="ORWDP WINPRINT DEFAULT"
    233         I ORDEV="WIN" S ORWINDEF="Y"
    234         E  S ORWINDEF="N"
    235         I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
    236         E  D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
    237         Q:ORDEV="WIN"
    238         ; If not Windows printer selected, save VistA default printer
    239         S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV
    240         I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
    241         E  D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
    242         Q
     1ORWRP ; ALB/MJK,dcm Report Calls ; 12/05/02 11:03
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262**;Dec 17, 1997;Build 3
     3 ;
     4LABLIST(LST) ; -- report list for labs tab
     5 ;  RPC: ORWRP LAB REPORT LIST
     6 N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD
     7 S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0
     8 D SETITEM(ROOT,"[LAB REPORT LIST]")
     9 D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST")
     10 F  S I=$O(ORLIST(I)) Q:'I  Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  S X0=^(0),X2=$G(^(2)) D
     11 . Q:$P(X0,"^",12)="L"
     12 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
     13 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
     14 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
     15 . D SETITEM(.ROOT,X)
     16 D SETITEM(.ROOT,"$$END")
     17 Q
     18LIST(LST) ; -- report lists for reports tab
     19 ;  RPC: ORWRP REPORT LIST
     20 N EOF,ROOT
     21 S EOF="$$END",ROOT=$NA(LST)
     22 K @ROOT
     23 D GETRPTS(.ROOT,.EOF) ; -report list
     24 D GETHS(.ROOT,.EOF) ; -health summary types
     25 D GETDT(.ROOT,.EOF) ; -date ranges
     26 Q
     27GETCOL(ROOT,IFN) ; -- get Column headers for ListView
     28 N I,J,X,VAL
     29 Q:'$G(IFN)
     30 S I=0,ROOT=$NA(ROOT)
     31 F  S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I  D
     32 . S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0
     33 . F  S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J  I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D
     34 .. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I)
     35 .. D SETITEM(.ROOT,X)
     36 Q
     37GETRPTS(ROOT,EOF) ; -- get report list
     38 N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD
     39 D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST")
     40 S (CNT,I)=0
     41 F  S I=$O(ORLIST(I)) Q:'I  Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  S X0=^(0),X2=$G(^(2)) D
     42 . Q:$P(X0,"^",12)="L"
     43 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
     44 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
     45 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
     46 . D SETITEM(.ROOT,X)
     47 D SETITEM(.ROOT,"$$END")
     48 Q
     49GETHS(ROOT,EOF) ; --get health summary types
     50 N C,I,IFN,ORHSPARM,ORERR,X,T
     51 K ^TMP("ORHSPARM",$J)
     52 S ORHSROOT="^TMP(""ORHSPARM"",$J)"
     53 I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D
     54 . F  S I=$O(^GMT(142,"B",I)) Q:I=""  S IFN=$O(^(I,0)) Q:'IFN  D
     55 .. S X=$G(^GMT(142,IFN,0)) Q:'$L(X)
     56 .. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1"
     57 .. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report"
     58 I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D
     59 . D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR)
     60 . Q:$G(ORERR)
     61 . S I=0 F  S I=$O(@ORHSROOT@(I)) Q:'I  S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report"
     62 D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
     63 S I=0  F  S I=$O(@ORHSROOT@(I)) Q:'I  D SETITEM(.ROOT,"h"_@ORHSROOT@(I))
     64 D SETITEM(.ROOT,EOF)
     65 Q
     66GETDT(ROOT,EOF) ; -- get date range choices
     67 N I,X
     68 D SETITEM(.ROOT,"[DATE RANGES]")
     69 F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF  D SETITEM(.ROOT,"d"_X)
     70 Q
     71DTLIST ; -- list of date ranges
     72 ;<number of days>^ <display text>
     73 ;;S^Date Range...
     74 ;;0^Today
     75 ;;7^One Week Back
     76 ;;14^Two Weeks Back
     77 ;;30^One Month Back
     78 ;;180^Six Months Back
     79 ;;365^One Year Back
     80 ;;$$END
     81 ;
     82SETITEM(ROOT,X) ; -- set item in list
     83 S @ROOT@($O(@ROOT@(9999),-1)+1)=X
     84 Q
     85RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text
     86 ;ROOT=Output in ^TMP("ORDATA",$J)
     87 ;DFN=Patient DFN ; ICN for foriegn sites
     88 ;RPTID=Unique id for the report_";"_Remote Id_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc)
     89 ;HSTYPE=Health Sum Type
     90 ;DTRANGE=# days back from today
     91 ;EXAMID=Rad exam ID
     92 ;ALPHA=Start date (lieu of DTRANGE)
     93 ;OMEGA=End date (lieu of DTRANGE)
     94 ;  RPC: ORWRP REPORT TEXT
     95 ;
     96 N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT
     97 K ^TMP("ORDATA",$J)
     98 S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":")
     99 I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls
     100 S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
     101 F  S I=$O(^ORD(101.24,"AC",I)) Q:I=""  S J=0 F  S J=$O(^ORD(101.24,"AC",I,J)) Q:'J  D
     102 . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)="R" S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3)
     103 I '$L(X0) D NOTYET(.ROOT) Q
     104 S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6)
     105 I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q
     106 I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q
     107 I $G(ALPHA) S X=ALPHA-$G(OMEGA) D
     108 . I X<0 S X=X*(-1)
     109 . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE=""
     110 I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA=""
     111 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959"
     112 I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959"
     113 ;S ID=$G(HSTAG),$P(ID,";",5,8)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)
     114 S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE
     115 I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4)
     116 I $L($G(HSTYPE)) M ID=HSTYPE
     117 I $L($G(EXAMID)) M ID=EXAMID
     118 S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)"
     119 I REMOTE S GO=0 D  Q:'GO
     120 . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q
     121 . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN)
     122 . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q
     123 . S GO=+$P(X0,"^",3)
     124 . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")")
     125 S %ZIS="0N"
     126 D @OUT
     127 Q
     128NOTYET(ROOT) ; -- not available
     129 D SETITEM(.ROOT,"Report not available at this time.")
     130 Q
     131START(RM,GOTO,ORIOSL) ;
     132 ;RM=Right margin
     133 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS
     134 S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP"
     135 D HFSOPEN(ORHANDLE,ORHFS,"W")
     136 I POP D  Q
     137 . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file")
     138 D IOVAR(.ORIO,.RM,.ORIOSL)
     139 N $ETRAP,$ESTACK
     140 S $ETRAP="D ERR^ORWRP Q"
     141 U IO
     142 D @GOTO
     143 D HFSCLOSE(ORHANDLE,ORHFS)
     144 Q
     145ERR ;Error trap
     146 S $ETRAP="D UNWIND^ORWRP Q"
     147 N %ZIS
     148 S %ZIS="0N"
     149 D @^%ZOSF("ERRTN") ;file error
     150 I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE)
     151 I $D(ORHFS) D
     152 . N ORARR,OROK
     153 . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file
     154 S $ECODE=",UOR69 error during CPRS report build,"
     155 Q
     156UNWIND ;Unwind Error stack
     157 Q:$ESTACK>1  ;pop stack
     158 ;
     159 Q
     160HFS() ; -- get hfs file name
     161 N H
     162 S H=$H
     163 Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT"
     164HFSOPEN(HANDLE,ORHFS,ORMODE) ;
     165 D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP
     166 Q
     167IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device
     168 N IFN,IFN1
     169 S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS")
     170 I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN
     171 I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^"))
     172 I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3))
     173 Q
     174HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data
     175 N ORDEL,X,%ZIS
     176 S %ZIS="0N"
     177 I IO[ORHFS D CLOSE^%ZISH(HANDLE)
     178 S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)=""
     179 K @ROOT
     180 S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4)
     181 D STRIP
     182 S X=$$DEL^%ZISH(,$NA(ORDEL))
     183 Q
     184USEHFS ; -- use host file to build global array
     185 N OROK,SECTION
     186 S SECTION=0
     187 D INIT
     188 S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q
     189 D STRIP
     190 N ORARR S ORARR(ORHFS)=""
     191 S OROK=$$DEL^%ZISH("",$NA(ORARR))
     192 Q
     193INIT ; -- initialize counts and global section
     194 S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION))
     195 K @ROOT
     196 Q
     197FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR
     198 N I
     199 F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION
     200 Q
     201STRIP ; -- strip off control chars
     202 N I,X
     203 S I=0 F  S I=$O(@ROOT@(I)) Q:'I  S X=^(I) D
     204 . I X[$C(8) D  ;BS
     205 .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q  ;BS & _
     206 .. S (X,@ROOT@(I))=$TR(X,$C(8),"")
     207 . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF
     208 Q
     209WINDFLT(ORY) ;Windows printer as default?
     210 S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT")
     211 Q
     212GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user
     213 N IEN,X0,ENT
     214 S ENT="ALL"
     215 I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC
     216 I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q
     217 S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0
     218 Q:'$D(^%ZIS(1,IEN,0))  S X0=^(0)
     219 S Y=IEN_";"_$P(X0,U)
     220 Q
     221SAVDFPRT(Y,ORDEV) ; Save new default printer for user
     222 N ORPAR,ORERR,ORWINDEF
     223 Q:$L(ORDEV)=0
     224 ; Reset Windows printer default to True/False
     225 S ORPAR="ORWDP WINPRINT DEFAULT"
     226 I ORDEV="WIN" S ORWINDEF="Y"
     227 E  S ORWINDEF="N"
     228 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
     229 E  D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
     230 Q:ORDEV="WIN"
     231 ; If not Windows printer selected, save VistA default printer
     232 S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV
     233 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
     234 E  D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
     235 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m

    r613 r623  
    1 ORWRP1  ; ALB/MJK,dcm Report Calls ;7/20/07  14:43
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 29
    3         ;
    4 AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)    ; - get adhoc health summary report
    5         D START^ORWRP(80,"AHSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    6         Q
    7 AHSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)   ; -build adhoc health summary
    8         N ORVP,GMTYP,Y
    9         S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTSTYP=+ORHS
    10         D ADHOC^ORPRS13
    11         Q
    12 HS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)     ; - get health summary report
    13         D START^ORWRP(80,"HSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    14         Q
    15 HSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)    ; - build health summary report
    16         N I,ICN,ORVP,GMTYP,Y,GMARXN,GMTSDLM,GMTSDTC,GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSEGR,GMSEQ,GMTSHDR,GMTSLCMP,GMTSNDM,GMTSNPK,GMTSPG,GMTSPHDR,X
    17         I $G(REMOTE) D  Q:'ORHS
    18         . S Y=$O(^GMT(142,"E",$P(ORHS,";",2),0))
    19         . I 'Y S Y=$O(^GMT(142,"E",$P($$UPPER^ORU(ORHS),";",2),0))
    20         . I 'Y S I=0 F  S I=$O(^GMT(142,I)) Q:'I  I $L($P($G(^GMT(142,I,"T")),"^")),$P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(^("T")) S Y=I Q
    21         . I 'Y S Y=$O(^GMT(142,"B",$P(ORHS,";",2),0))
    22         . I 'Y S Y=$O(^GMT(142,"B",$P($$UPPER^ORU(ORHS),";",2),0))
    23         . I 'Y S I=0 F  S I=$O(^GMT(142,I)) Q:'I  S X=$P(^(I,0),"^") I $P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(X) S Y=I Q
    24         . I 'Y U IO W !,ORHS_" not found on remote system",! S ORHS=Y Q
    25         . S ORHS=Y
    26         I +$G(ORHS)<1 W !,"Report not Available" Q
    27         S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTYP(0)=1,GMTYP(1)=+ORHS_U_Y_U_Y_U_Y
    28         D PQ^ORPRS13
    29         Q
    30 HSTYPE(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Get HS type report
    31         D START^ORWRP(80,"HSTYPEB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    32         Q
    33 HSTYPEB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)        ; - Build HS type report
    34         N GMTSQIT,GMTSPRM,GMTSTITL,GMTSPX2,GMTSPX1
    35         I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
    36         Q:'$G(ALPHA)  Q:'$G(OMEGA)
    37         I +$G(ORHS)<1 W !,"Report not Available" Q
    38         S GMTSQIT=1,GMTSPRM=$P($G(^GMT(142.1,+ORHS,0)),"^",4),GMTSTITL="",GMTSPX2=ALPHA,GMTSPX1=OMEGA,DFN=ORDFN
    39         D ENCWA^GMTS
    40         Q
    41 HSGUI(DFN,GMTSTYP)      ; - Call ENX^GMTSDVR to print HS Type for Patient
    42         D ENX^GMTSDVR(DFN,GMTSTYP)
    43         Q
    44 BLR(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)      ; -- get 'enhanced' blood bank report
    45         N DFN,ORY,ORSBHEAD
    46         S DFN=ORDFN
    47         I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D  Q  ;Transition to VBEC's interface
    48         . K ^TMP("ORLRC",$J)
    49         . D EN^ORWLR1(DFN)
    50         . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
    51         . S ROOT=$NA(^TMP("ORLRC",$J))
    52         K ^TMP("LRC",$J)
    53         S ORSBHEAD("BLOOD BANK")=""
    54         D EN^LR7OSUM(.ORY,DFN,,,,,.ORSBHEAD)
    55         I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Blood Bank report available..."
    56         S ROOT=$NA(^TMP("LRC",$J))
    57         Q
    58 AP(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ; -- get Anatomic path report
    59         N I,C,LINES,X
    60         K ^TMP("LRC",$J),^TMP("LRH",$J)
    61         D AP^LR7OSUM(ORDFN)
    62         I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Anatomic Pathology reports available..."
    63         S I=0
    64         I $L($O(^TMP("LRH",$J,0))) S I=.001,^TMP("LRC",$J,I)="[HIDDEN TEXT]^" D
    65         . S X="",C=2 F  S X=$O(^TMP("LRH",$J,X)) Q:X=""  S LINES(^(X))=X,C=C+1
    66         . S $P(^TMP("LRC",$J,.001),"^",2)=C
    67         . S X="" F  S X=$O(LINES(X)) Q:X=""  D
    68         .. S I=I+.001,^TMP("LRC",$J,I)=X_"^"_LINES(X)
    69         . S I=I+.001,^TMP("LRC",$J,I)="[REPORT TEXT]"
    70         S ROOT=$NA(^TMP("LRC",$J))
    71         K ^TMP("LRH",$J)
    72         Q
    73 DIET(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ; -- get dietetics profile
    74         N LCNT,ORVP
    75         S LCNT=0,ORVP=DFN_";DPT("
    76         D FHP^ORCXPNDR
    77         S ROOT=$NA(^TMP("ORXPND",$J))
    78         Q
    79 LISTNUTR(ROOT,DFN)      ; -- list nutritional assessments
    80         N OK,I,X
    81         K ^TMP($J,"FHADT")
    82         S OK=$$FHWORADT^FHWORA(DFN)
    83         S I=0,SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
    84         F  S I=$O(^TMP($J,"FHADT",DFN,I)) Q:'I  S X=SITE_U_I_U_^(I),^(I)=X
    85         S ROOT=$NA(^TMP($J,"FHADT",DFN))
    86         Q
    87 NUTR(ROOT,DFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)       ; -- get nutritional assessment
    88         N LCNT,ORVP
    89         K ^TMP("ORXPND",$J)
    90         S LCNT=0,ORVP=DFN_";DPT(",ID=DFN_";"_ID
    91         D FHA^ORCXPNDR
    92         S ROOT=$NA(^TMP("ORXPND",$J))
    93         Q
    94 VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)   ; -- get vitals report
    95         D START^ORWRP(132,"VITALSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
    96         D EN^GMRVPGC(ORDFN) Q
    97 VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)  ; -- build vitals report
    98         N ORVP,XQORNOD,ORSSTRT,ORSSTOP
    99         Q:'$G(ORDFN)
    100         I $L(ORDTRNG),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OMEGA=$$NOW^XLFDT
    101         Q:'$G(ALPHA)  Q:'$G(OMEGA)
    102         I '$P(OMEGA,".",2) S OMEGA=OMEGA_".2359"
    103         S ORVP=ORDFN_";DPT(",XQORNOD=1,ORSSTRT(XQORNOD)=ALPHA,ORSSTOP(XQORNOD)=OMEGA
    104         D VITCUM^ORPRS14
    105         Q
    106 STAT(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Lab Order Status
    107         N ORVP
    108         K ^TMP("ORDATA",$J)
    109         S ORVP=ORDFN_";DPT("
    110         D EN1^LR7OSOS1(.ORY,ORVP,.ORALPHA,.OROMEGA,.ORDTRNG)
    111         I '$O(^TMP("ORDATA",$J,1,0)) S ^TMP("ORDATA",$J,1,1,0)="",^TMP("ORDATA",$J,1,2,0)="No Orders found..."
    112         S ROOT=ORY
    113         Q
    114 INTERIM(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)      ;Lab Interim
    115         D START^ORWRP(80,"INTERIMB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    116         Q
    117 INTERIMB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)   ;Build Interim
    118         Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
    119         N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LRACC,LRAD,LRAN,LRRT,LRPG,LRSB,LREDT,LRIDT
    120         S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRIDT)=(9999999-OMEGA)
    121         D OERR^LRRP4,CLEAN^LRRP4
    122         Q
    123 LRGEN(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)        ;Lab results by test
    124         D START^ORWRP(80,"LRGENB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    125         Q
    126 LRGENB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)     ;Build Results
    127         Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
    128         N ORVP,ORSSTRT,ORSSTOP,LREDT,LRSDT,XQORNOD
    129         S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRSDT)=(9999999-OMEGA)
    130         D SET1^LRGEN,CLEAN^LRRP4
    131         K LRPR
    132         Q
    133 GRAPH(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)        ;Graph labs
    134         D START^ORWRP(80,"GRAPHB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    135         Q
    136 GRAPHB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)     ;Graph labs
    137         Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
    138         N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LREDT,LRSDT
    139         S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=ALPHA,(ORSSTOP(XQORNOD),LRSDT)=OMEGA
    140         D OERR^LRDIST4,CLEAN^LRDIST4
    141         Q
    142 ORS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)      ;Daily order summary
    143         D START^ORWRP(80,"ORSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
    144         Q
    145 ORSB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ;Daily order summary
    146         N ORVP,XQORNOD,ORSSTRT,ORSSTOP
    147         S ORVP=DFN_";DPT(",XQORNOD=1,X1=DT,X2=-$S(DTRANGE:DTRANGE-1,1:0)
    148         D C^%DTC
    149         S ORSSTRT=X-.7641,ORSSTOP=DT+.2359
    150         D DAY^ORPRS02
    151         Q
    152 ORD(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)  ;Order Summary for Date Range
    153         D START^ORWRP(80,"ORDB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
    154         Q
    155 ORDB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ;Order Summary for Date Range
    156         Q:'$G(DFN)
    157         I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
    158         Q:'$G(ALPHA)  Q:'$G(OMEGA)
    159         N ORVP,XQORNOD,ORSSTRT,ORSSTOP
    160         S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA
    161         D RANGE^ORPRS02
    162         Q
    163 ORC(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)  ;Custom order summary
    164         D START^ORWRP(80,"ORCB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    165         Q
    166 ORCB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ;Custom order summary build
    167         Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
    168         N ORVP,XQORNOD,ORSSTRT,ORSSTOP
    169         S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA
    170         D CUSTOM^ORPRS02
    171         Q
    172 ORP(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)  ;Chart copy summary
    173         D START^ORWRP(80,"ORPB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORFHIE)")
    174         Q
    175 ORPB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ;Chart copy summary
    176         Q:'$G(DFN)
    177         I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
    178         Q:'$G(ALPHA)  Q:'$G(OMEGA)
    179         N ORVP,XQORNOD,ORSSTRT,ORSSTOP
    180         S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA
    181         D CHART^ORPRS02
    182         Q
    183 PSO(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)      ;Outpatient RX Profile
    184         D START^ORWRP(80,"PSOB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORFHIE)")
    185         Q
    186 PSOB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)       ;Outpatient RX Action Profile
    187         N ORVP,PSTYPE,PSONOPG
    188         S ORVP=DFN_";DPT(",PSTYPE=1,PSONOPG=2
    189         D DFN^PSOSD1
    190         Q
    191 MED(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)     ;Medicine Summary of Procedures
    192         D START^ORWRP(80,"MEDB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    193         Q
    194 MEDB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)      ;Medicine Summary of Procedures
    195         Q:'$L($G(IID))
    196         N ORVP,XQY0,OT,MCARPPS,MCPRO,MCARGRTN,DXS,SSN,I,J,L,DA,MCARGDA
    197         S ORVP=DFN_";DPT(",XQY0="",OT=$G(^TMP("OR",$J,"MCAR","OT",IID))
    198         Q:'$L(OT)
    199         S (DA,MCARGDA)=$P(OT,U,2),MCARPPS=$P(OT,U,3,4),MCPRO=$P(OT,U,11)
    200         D MCPPROC^MCARP
    201         S MCARGRTN=$P(OT,U,5)
    202         D @MCARPPS
    203         Q
    204 PROB(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)    ; Problem List (Problem Tab)
    205         D START^ORWRP(80,"PROBB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
    206         Q
    207 PROBB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE)     ;Problem List
    208         N ORSILENT S ORSILENT=1
    209         D VAF^GMPLUTL2(DFN,ORSILENT)
    210         Q
     1ORWRP1 ; ALB/MJK,dcm Report Calls ;7/20/07  14:43
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 28
     3 ;
     4AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get adhoc health summary report
     5 D START^ORWRP(80,"AHSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     6 Q
     7AHSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -build adhoc health summary
     8 N ORVP,GMTYP,Y
     9 S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTSTYP=+ORHS
     10 D ADHOC^ORPRS13
     11 Q
     12HS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get health summary report
     13 D START^ORWRP(80,"HSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     14 Q
     15HSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - build health summary report
     16 N I,ICN,ORVP,GMTYP,Y,GMARXN,GMTSDLM,GMTSDTC,GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSEGR,GMSEQ,GMTSHDR,GMTSLCMP,GMTSNDM,GMTSNPK,GMTSPG,GMTSPHDR,X
     17 I $G(REMOTE) D  Q:'ORHS
     18 . S Y=$O(^GMT(142,"E",$P(ORHS,";",2),0))
     19 . I 'Y S Y=$O(^GMT(142,"E",$P($$UPPER^ORU(ORHS),";",2),0))
     20 . I 'Y S I=0 F  S I=$O(^GMT(142,I)) Q:'I  I $L($P($G(^GMT(142,I,"T")),"^")),$P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(^("T")) S Y=I Q
     21 . I 'Y S Y=$O(^GMT(142,"B",$P(ORHS,";",2),0))
     22 . I 'Y S Y=$O(^GMT(142,"B",$P($$UPPER^ORU(ORHS),";",2),0))
     23 . I 'Y S I=0 F  S I=$O(^GMT(142,I)) Q:'I  S X=$P(^(I,0),"^") I $P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(X) S Y=I Q
     24 . I 'Y U IO W !,ORHS_" not found on remote system",! S ORHS=Y Q
     25 . S ORHS=Y
     26 I +$G(ORHS)<1 W !,"Report not Available" Q
     27 S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTYP(0)=1,GMTYP(1)=+ORHS_U_Y_U_Y_U_Y
     28 D PQ^ORPRS13
     29 Q
     30HSTYPE(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Get HS type report
     31 D START^ORWRP(80,"HSTYPEB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     32 Q
     33HSTYPEB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Build HS type report
     34 N GMTSQIT,GMTSPRM,GMTSTITL,GMTSPX2,GMTSPX1
     35 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
     36 Q:'$G(ALPHA)  Q:'$G(OMEGA)
     37 I +$G(ORHS)<1 W !,"Report not Available" Q
     38 S GMTSQIT=1,GMTSPRM=$P($G(^GMT(142.1,+ORHS,0)),"^",4),GMTSTITL="",GMTSPX2=ALPHA,GMTSPX1=OMEGA,DFN=ORDFN
     39 D ENCWA^GMTS
     40 Q
     41HSGUI(DFN,GMTSTYP) ; - Call ENX^GMTSDVR to print HS Type for Patient
     42 D ENX^GMTSDVR(DFN,GMTSTYP)
     43 Q
     44BLR(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get 'enhanced' blood bank report
     45 N DFN,ORY,ORSBHEAD
     46 S DFN=ORDFN
     47 I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D  Q  ;Transition to VBEC's interface
     48 . K ^TMP("ORLRC",$J)
     49 . D EN^ORWLR1(DFN)
     50 . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
     51 . S ROOT=$NA(^TMP("ORLRC",$J))
     52 K ^TMP("LRC",$J)
     53 S ORSBHEAD("BLOOD BANK")=""
     54 D EN^LR7OSUM(.ORY,DFN,,,,,.ORSBHEAD)
     55 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Blood Bank report available..."
     56 S ROOT=$NA(^TMP("LRC",$J))
     57 Q
     58AP(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get Anatomic path report
     59 N I,C,LINES,X
     60 K ^TMP("LRC",$J),^TMP("LRH",$J)
     61 D AP^LR7OSUM(ORDFN)
     62 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Anatomic Pathology reports available..."
     63 S I=0
     64 I $L($O(^TMP("LRH",$J,0))) S I=.001,^TMP("LRC",$J,I)="[HIDDEN TEXT]^" D
     65 . S X="",C=2 F  S X=$O(^TMP("LRH",$J,X)) Q:X=""  S LINES(^(X))=X,C=C+1
     66 . S $P(^TMP("LRC",$J,.001),"^",2)=C
     67 . S X="" F  S X=$O(LINES(X)) Q:X=""  D
     68 .. S I=I+.001,^TMP("LRC",$J,I)=X_"^"_LINES(X)
     69 . S I=I+.001,^TMP("LRC",$J,I)="[REPORT TEXT]"
     70 S ROOT=$NA(^TMP("LRC",$J))
     71 K ^TMP("LRH",$J)
     72 Q
     73DIET(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get dietetics profile
     74 N LCNT,ORVP
     75 S LCNT=0,ORVP=DFN_";DPT("
     76 D FHP^ORCXPNDR
     77 S ROOT=$NA(^TMP("ORXPND",$J))
     78 Q
     79LISTNUTR(ROOT,DFN) ; -- list nutritional assessments
     80 N OK,I,X
     81 K ^TMP($J,"FHADT")
     82 S OK=$$FHWORADT^FHWORA(DFN)
     83 S I=0,SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
     84 F  S I=$O(^TMP($J,"FHADT",DFN,I)) Q:'I  S X=SITE_U_I_U_^(I),^(I)=X
     85 S ROOT=$NA(^TMP($J,"FHADT",DFN))
     86 Q
     87NUTR(ROOT,DFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get nutritional assessment
     88 N LCNT,ORVP
     89 K ^TMP("ORXPND",$J)
     90 S LCNT=0,ORVP=DFN_";DPT(",ID=DFN_";"_ID
     91 D FHA^ORCXPNDR
     92 S ROOT=$NA(^TMP("ORXPND",$J))
     93 Q
     94VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get vitals report
     95 D START^ORWRP(132,"VITALSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
     96 D EN^GMRVPGC(ORDFN) Q
     97VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build vitals report
     98 N ORVP,XQORNOD,ORSSTRT,ORSSTOP
     99 Q:'$G(ORDFN)
     100 I $L(ORDTRNG),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OMEGA=$$NOW^XLFDT
     101 Q:'$G(ALPHA)  Q:'$G(OMEGA)
     102 I '$P(OMEGA,".",2) S OMEGA=OMEGA_".2359"
     103 S ORVP=ORDFN_";DPT(",XQORNOD=1,ORSSTRT(XQORNOD)=ALPHA,ORSSTOP(XQORNOD)=OMEGA
     104 D VITCUM^ORPRS14
     105 Q
     106STAT(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Lab Order Status
     107 N ORVP
     108 K ^TMP("ORDATA",$J)
     109 S ORVP=ORDFN_";DPT("
     110 D EN1^LR7OSOS1(.ORY,ORVP,.ORALPHA,.OROMEGA,.ORDTRNG)
     111 I '$O(^TMP("ORDATA",$J,1,0)) S ^TMP("ORDATA",$J,1,1,0)="",^TMP("ORDATA",$J,1,2,0)="No Orders found..."
     112 S ROOT=ORY
     113 Q
     114INTERIM(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab Interim
     115 D START^ORWRP(80,"INTERIMB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     116 Q
     117INTERIMB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Interim
     118 Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
     119 N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LRACC,LRAD,LRAN,LRRT,LRPG,LRSB,LREDT,LRIDT
     120 S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRIDT)=(9999999-OMEGA)
     121 D OERR^LRRP4,CLEAN^LRRP4
     122 Q
     123LRGEN(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab results by test
     124 D START^ORWRP(80,"LRGENB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     125 Q
     126LRGENB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Results
     127 Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
     128 N ORVP,ORSSTRT,ORSSTOP,LREDT,LRSDT,XQORNOD
     129 S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRSDT)=(9999999-OMEGA)
     130 D SET1^LRGEN,CLEAN^LRRP4
     131 K LRPR
     132 Q
     133GRAPH(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs
     134 D START^ORWRP(80,"GRAPHB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     135 Q
     136GRAPHB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs
     137 Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
     138 N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LREDT,LRSDT
     139 S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=ALPHA,(ORSSTOP(XQORNOD),LRSDT)=OMEGA
     140 D OERR^LRDIST4,CLEAN^LRDIST4
     141 Q
     142ORS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Daily order summary
     143 D START^ORWRP(80,"ORSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
     144 Q
     145ORSB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Daily order summary
     146 N ORVP,XQORNOD,ORSSTRT,ORSSTOP
     147 S ORVP=DFN_";DPT(",XQORNOD=1,X1=DT,X2=-$S(DTRANGE:DTRANGE-1,1:0)
     148 D C^%DTC
     149 S ORSSTRT=X-.7641,ORSSTOP=DT+.2359
     150 D DAY^ORPRS02
     151 Q
     152ORD(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range
     153 D START^ORWRP(80,"ORDB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
     154 Q
     155ORDB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range
     156 Q:'$G(DFN)
     157 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
     158 Q:'$G(ALPHA)  Q:'$G(OMEGA)
     159 N ORVP,XQORNOD,ORSSTRT,ORSSTOP
     160 S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA
     161 D RANGE^ORPRS02
     162 Q
     163ORC(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary
     164 D START^ORWRP(80,"ORCB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     165 Q
     166ORCB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary build
     167 Q:'$G(DFN)  Q:'$G(ALPHA)  Q:'$G(OMEGA)
     168 N ORVP,XQORNOD,ORSSTRT,ORSSTOP
     169 S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA
     170 D CUSTOM^ORPRS02
     171 Q
     172ORP(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Chart copy summary
     173 D START^ORWRP(80,"ORPB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORFHIE)")
     174 Q
     175ORPB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Chart copy summary
     176 Q:'$G(DFN)
     177 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
     178 Q:'$G(ALPHA)  Q:'$G(OMEGA)
     179 N ORVP,XQORNOD,ORSSTRT,ORSSTOP
     180 S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA
     181 D CHART^ORPRS02
     182 Q
     183PSO(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Profile
     184 D START^ORWRP(80,"PSOB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORFHIE)")
     185 Q
     186PSOB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Action Profile
     187 N ORVP,PSTYPE,PSONOPG
     188 S ORVP=DFN_";DPT(",PSTYPE=1,PSONOPG=2
     189 D DFN^PSOSD1
     190 Q
     191MED(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures
     192 D START^ORWRP(80,"MEDB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     193 Q
     194MEDB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures
     195 Q:'$L($G(IID))
     196 N ORVP,XQY0,OT,MCARPPS,MCPRO,MCARGRTN,DXS,SSN,I,J,L,DA,MCARGDA
     197 S ORVP=DFN_";DPT(",XQY0="",OT=$G(^TMP("OR",$J,"MCAR","OT",IID))
     198 Q:'$L(OT)
     199 S (DA,MCARGDA)=$P(OT,U,2),MCARPPS=$P(OT,U,3,4),MCPRO=$P(OT,U,11)
     200 D MCPPROC^MCARP
     201 S MCARGRTN=$P(OT,U,5)
     202 D @MCARPPS
     203 Q
     204PROB(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; Problem List (Problem Tab)
     205 D START^ORWRP(80,"PROBB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)")
     206 Q
     207PROBB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Problem List
     208 N ORSILENT S ORSILENT=1
     209 D VAF^GMPLUTL2(DFN,ORSILENT)
     210 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP3.m

    r613 r623  
    1 ORWRP3  ; slc/dcm - OE/RR Report Extract RPC's ; 08 May 2001  13:32PM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,215,243**;Dec 17, 1997;Build 242
    3         ;
    4         ; DBIA 4011   Access ^XWB(8994)
    5         ;
    6 EX(ROOT,TST)    ;Expand columns
    7          ;TST=ptr to file 101.24
    8          ;Y(i)=id^Name^Qualifier^IOM^Entry^Routine^Remote^Type^Category^RPC^ifn^sort_order^max_days^direct^hdr^fhie
    9          Q:'$G(TST)
    10          N J,X,X0,X1,X2,X4,RPC,HEAD,ORX0,ORX2,ORX4,ORX,ORTIMOCC,MAX
    11          I '$L($G(C)) S C=0
    12          S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS INDV",+TST,"I")
    13          I '$L(ORTIMOCC) S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
    14          S X0=$G(^ORD(101.24,+TST,0)),X2=$G(^(2)),X4=$G(^(4)),MAX=$P(X4,"^",2),X=$P($P(ORTIMOCC,";"),"-",2)
    15          I $P(X4,"^",10) Q
    16          I X,MAX,X>MAX S ORTIMOCC="T-"_MAX_";"_$P(ORTIMOCC,";",2,99)
    17          I '$L(ORTIMOCC) S ORTIMOCC=";;"
    18          I '$O(^ORD(101.24,+TST,10,0)) D  Q
    19          . Q:$P(X0,"^",12)="L"
    20          . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^")  ;DBIA 4011
    21          . S HEAD=$P(X0,"^")
    22          . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
    23          . S X1=$P(X0,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X0,U,4)_U_$P(X0,U,19)_";"_$P(X0,U,20)_";"
    24          . S X=X1_+$P(X0,U,21)_U_$P(X0,U,6)_U_$P(X0,U,5)_U_$P(X0,U,3)_U_$P(X0,U,12)_U_$P(X0,U,7)_U_RPC_U_+TST_U_$P(X4,U)_U_$P(X4,U,2)_U_$P(X4,U,4)_U_$P(X4,U,5)_U_$P(X4,U,8)_U_$P(X4,U,9)
    25          . D SETITEM(.ROOT,X)
    26          I $O(^ORD(101.24,+TST,10,0)) S ORX0=^ORD(101.24,+TST,0),ORX2=$G(^(2)),ORX4=$G(^(4)) D
    27          . I $P(ORX4,"^",10) Q
    28          . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^")  ;DBIA 4011
    29          . S X=ORX0,HEAD=$P(X,"^")
    30          . I $L($P(ORX2,"^",3)) S HEAD=$P(ORX2,"^",3)
    31          . S X1=$P(X,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X,U,4)_U_$P(X,U,19)_";"_$P(X,U,20)_";"
    32          . S ORX=X1_+$P(X,U,21)_U_$P(X,U,6)_U_$P(X,U,5)_U_$P(X,U,3)_U_$P(X,U,12)_U_$P(X,U,7)_U_RPC_U_+TST_U_$P(ORX4,U)_U_$P(ORX4,U,2)_U_$P(ORX4,U,4)_U_$P(ORX4,U,5)_U_$P(ORX4,U,8)_U_$P(X4,U,9)
    33          . D SETITEM(.ROOT,"[PARENT START]^"_ORX)
    34          . S J=0 F  S J=$O(^ORD(101.24,+TST,10,J)) Q:J<1  S X=^(J,0) D EX(.ROOT,+X)
    35          . D SETITEM(.ROOT,"[PARENT END]^"_ORX)
    36          Q
    37 LIST(LST,TAB)         ;Get list for Reports & Labs Tab Treeview
    38         N ROOT
    39         S ROOT=$NA(LST)
    40         K @ROOT
    41         D TRY1(.ROOT,$G(TAB))
    42         Q
    43 TRY1(ROOT,TAB)     ;Test expanding reports using established parameters
    44         N I,ORLIST
    45         D SETITEM(.ROOT,"[REPORT LIST]")
    46         D GETLST^XPAR(.ORLIST,"ALL",$S($G(TAB)="LABS":"ORWRP REPORT LAB LIST",1:"ORWRP REPORT LIST"))
    47         S I=0
    48         F  S I=$O(ORLIST(I)) Q:'I  Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  D EX(.ROOT,$P(ORLIST(I),"^",2))
    49         D SETITEM(.ROOT,"$$END")
    50         Q
    51 SETITEM(ROOT,X) ; -- set item in list
    52         S @ROOT@($O(@ROOT@(9999),-1)+1)=X
    53         Q
     1ORWRP3 ; slc/dcm - OE/RR Report Extract RPC's ; 08 May 2001  13:32PM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,215**;Dec 17, 1997
     3 ;
     4 ; DBIA 4011   Access ^XWB(8994)
     5 ;
     6EX(ROOT,TST) ;Expand columns
     7  ;TST=ptr to file 101.24
     8  ;Y(i)=id^Name^Qualifier^IOM^Entry^Routine^Remote^Type^Category^RPC^ifn^sort_order^max_days^direct
     9  Q:'$G(TST)
     10  N J,X,X0,X2,X4,RPC,HEAD,ORX0,ORX2,ORX4,ORX,ORTIMOCC,MAX
     11  I '$L($G(C)) S C=0
     12  S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS INDV",+TST,"I")
     13  I '$L(ORTIMOCC) S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
     14  S X0=$G(^ORD(101.24,+TST,0)),X2=$G(^(2)),X4=$G(^(4)),MAX=$P(X4,"^",2),X=$P($P(ORTIMOCC,";"),"-",2)
     15  I X,MAX,X>MAX S ORTIMOCC="T-"_MAX_";"_$P(ORTIMOCC,";",2,99)
     16  I '$L(ORTIMOCC) S ORTIMOCC=";;"
     17  I '$O(^ORD(101.24,+TST,10,0)) D  Q
     18  . Q:$P(X0,"^",12)="L"
     19  . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^")  ;DBIA 4011
     20  . S HEAD=$P(X0,"^") I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
     21  . S X=$P(X0,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X0,U,4)_U_$P(X0,U,19)_";"_$P(X0,U,20)_";"_+$P(X0,U,21)_U_$P(X0,U,6)_U_$P(X0,U,5)_U_$P(X0,U,3)_U_$P(X0,U,12)_U_$P(X0,U,7)_U_RPC_U_+TST_U_$P(X4,U)_U_$P(X4,U,2)_U_$P(X4,U,4)_U_$P(X4,U,5)
     22  . D SETITEM(.ROOT,X)
     23  I $O(^ORD(101.24,+TST,10,0)) S ORX0=^ORD(101.24,+TST,0),ORX2=$G(^(2)),ORX4=$G(^(4)) D
     24  . S X=ORX0,HEAD=$P(X,"^")
     25  . I $L($P(ORX2,"^",3)) S HEAD=$P(ORX2,"^",3)
     26  . S ORX=$P(X,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X,U,4)_U_$P(X,U,19)_";"_$P(X,U,20)_";"_+$P(X,U,21)_U_$P(X,U,6)_U_$P(X,U,5)_U_$P(X,U,3)_U_$P(X,U,12)_U_$P(X,U,7)_"^^"_+TST_U_$P(ORX4,U)_U_$P(ORX4,U,2)_U_$P(ORX4,U,4)_U_$P(ORX4,U,5)
     27  . D SETITEM(.ROOT,"[PARENT START]^"_ORX)
     28  . S J=0 F  S J=$O(^ORD(101.24,+TST,10,J)) Q:J<1  S X=^(J,0) D EX(.ROOT,+X)
     29  . D SETITEM(.ROOT,"[PARENT END]^"_ORX)
     30  Q
     31LIST(LST)       ;Get list for Treeview
     32 N ROOT
     33 S ROOT=$NA(LST)
     34 K @ROOT
     35 D TRY1(.ROOT)
     36 Q
     37TRY1(ROOT)    ;Test expanding reports using established parameters
     38 N I,ORLIST
     39 D SETITEM(.ROOT,"[REPORT LIST]")
     40 D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST")
     41 S I=0
     42 F  S I=$O(ORLIST(I)) Q:'I  Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0))  D EX(.ROOT,$P(ORLIST(I),"^",2))
     43 D SETITEM(.ROOT,"$$END")
     44 Q
     45SETITEM(ROOT,X) ; -- set item in list
     46 S @ROOT@($O(@ROOT@(9999),-1)+1)=X
     47 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4P.m

    r613 r623  
    1 ORWRP4P  ; slc/dcm - OE/RR HDR Report Extract RPC's Outpatient Pharmacy ;9/21/05  13:21
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3 PSO     ;Outpatient RX for HDR
    4         N IFN,IFN1,IFN2,X,X1,X2,X3,X10,X16,X17,XIFN,ORX,COL,CODE,I1,CNT,%DT,Y,FAC,FACU
    5         K ^TMP("ORXS",$J)
    6         S IFN=""
    7         F  S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN=""  S XIFN=^(IFN) D
    8         . S X16=$P(XIFN,"^",16),X17=$P(XIFN,"^",17),X2=$P(XIFN,"^",2),FACU=X17
    9         . I X17="",X16,X16'=200 S FACU=$O(^DIC(4,"D",X16,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^")
    10         . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown")
    11         . S $P(XIFN,"^",2)=FACU,X10=$P($P(XIFN,"^",10),":",1,2),X3=$P($P(XIFN,"^",3),"~",2)
    12         . I X3="" S X3=$P($P(XIFN,"^",4),"~",2) ;Get NDC name if Drug name not sent
    13         . I $L(X10),$L(X3) D
    14         .. S X10=9999999-$$SETDATE^ORWRP4(X10),^TMP("ORXS",$J,FACU,X10,X3,IFN)=XIFN
    15         K ^TMP("ORXS1",$J)
    16         S FAC="",CNT=-1
    17         F  S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN=""  D
    18         . S IFN1=""
    19         . F  S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1=""  S IFN2="" F  S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2=""  S X=^(IFN2) D
    20         .. D XSET^ORWRP4("1^"_$P(X,"^",2)) ; Facility
    21         .. D XSET^ORWRP4("2^"_IFN1) ; Drug Name
    22         .. D XSET^ORWRP4("3^"_$P($P(X,"^",3),"~")) ; Drug IEN
    23         .. D XSET^ORWRP4("4^"_$P(X,"^",5)) ; RX #
    24         .. D XSET^ORWRP4("5^"_$P($P(X,"^",6),"~",2)) ; Status
    25         .. D XSET^ORWRP4("6^"_$P(X,"^",7)) ; Qty
    26         .. S Y=$$SETDATE^ORWRP4($P(X,"^",9)) D XSET^ORWRP4("7^"_$$DATE^ORDVU(Y)) ; Exp/Canc Date
    27         .. S Y=$$SETDATE^ORWRP4($P(X,"^",10)) D XSET^ORWRP4("8^"_$$DATE^ORDVU(Y)) ; Issue Date
    28         .. S Y=$$SETDATE^ORWRP4($P(X,"^",11)) D XSET^ORWRP4("9^"_$$DATE^ORDVU(Y)) ; Last Fill Date
    29         .. D XSET^ORWRP4("10^"_$P(X,"^",12)) ; Refills
    30         .. D XSET^ORWRP4("11^"_$P(X,"^",13)) ; Provider
    31         .. D XSET^ORWRP4("12^"_$P(X,"^",14)) ; Cost/Fill
    32         .. D XSET^ORWRP4("13^"_$S($L($P(X,"^",15))>60:"[+]",1:"")) ; [+]
    33         .. D XSET^ORWRP4("14^"_$P(X,"^",15)) ; SIG
    34         K ^XTMP(HANDLE,"D") M ^XTMP(HANDLE,"D")=^TMP("ORXS1",$J) K ^TMP("ORXS",$J),^TMP("ORXS1",$J)
    35         Q
     1ORWRP4P  ; slc/dcm - OE/RR HDR Report Extract RPC's Outpatient Pharmacy ;9/21/05  13:21
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3PSO ;Outpatient RX for HDR
     4 N IFN,IFN1,IFN2,X,X1,X2,X3,X10,X16,X17,XIFN,ORX,COL,CODE,I1,CNT,%DT,Y,FAC,FACU
     5 K ^TMP("ORXS",$J)
     6 S IFN=""
     7 F  S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN=""  S XIFN=^(IFN) D
     8 . S X16=$P(XIFN,"^",16),X17=$P(XIFN,"^",17),X2=$P(XIFN,"^",2),FACU=X17
     9 . I X17="",X16,X16'=200 S FACU=$O(^DIC(4,"D",X16,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^")
     10 . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown")
     11 . S $P(XIFN,"^",2)=FACU,X10=$P($P(XIFN,"^",10),":",1,2),X3=$P($P(XIFN,"^",3),"~",2)
     12 . I X3="" S X3=$P($P(XIFN,"^",4),"~",2) ;Get NDC name if Drug name not sent
     13 . I $L(X10),$L(X3) D
     14 .. S X10=9999999-$$SETDATE^ORWRP4(X10),^TMP("ORXS",$J,FACU,X10,X3,IFN)=XIFN
     15 K ^TMP("ORXS1",$J)
     16 S FAC="",CNT=-1
     17 F  S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN=""  D
     18 . S IFN1=""
     19 . F  S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1=""  S IFN2="" F  S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2=""  S X=^(IFN2) D
     20 .. D XSET^ORWRP4("1^"_$P(X,"^",2)) ; Facility
     21 .. D XSET^ORWRP4("2^"_IFN1) ; Drug Name
     22 .. D XSET^ORWRP4("3^"_$P($P(X,"^",3),"~")) ; Drug IEN
     23 .. D XSET^ORWRP4("4^"_$P(X,"^",5)) ; RX #
     24 .. D XSET^ORWRP4("5^"_$P($P(X,"^",6),"~",2)) ; Status
     25 .. D XSET^ORWRP4("6^"_$P(X,"^",7)) ; Qty
     26 .. S Y=$$SETDATE^ORWRP4($P(X,"^",9)) D XSET^ORWRP4("7^"_$$DATE^ORDVU(Y)) ; Exp/Canc Date
     27 .. S Y=$$SETDATE^ORWRP4($P(X,"^",10)) D XSET^ORWRP4("8^"_$$DATE^ORDVU(Y)) ; Issue Date
     28 .. S Y=$$SETDATE^ORWRP4($P(X,"^",11)) D XSET^ORWRP4("9^"_$$DATE^ORDVU(Y)) ; Last Fill Date
     29 .. D XSET^ORWRP4("10^"_$P(X,"^",12)) ; Refills
     30 .. D XSET^ORWRP4("11^"_$P(X,"^",13)) ; Provider
     31 .. D XSET^ORWRP4("12^"_$P(X,"^",14)) ; Cost/Fill
     32 .. D XSET^ORWRP4("13^") ; [+]
     33 .. D XSET^ORWRP4("14^"_$P(X,"^",15)) ; SIG
     34 K ^XTMP(HANDLE,"D") M ^XTMP(HANDLE,"D")=^TMP("ORXS1",$J) K ^TMP("ORXS",$J),^TMP("ORXS1",$J)
     35 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4V.m

    r613 r623  
    1 ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05  13:21
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
    3 VS      ;Vitals code for HDR
    4         N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE,QUALIF,METHOD,UNIT
    5         K ^TMP("ORXS",$J)
    6         S IFN=""
    7         F  S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN=""  S XIFN=^(IFN) D
    8         . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12
    9         . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^")
    10         . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown")
    11         . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2)
    12         . I $P(XIFN,"^",10)'="W",$L(X5) D
    13         .. S X4=9999999-$$SETDATE^ORWRP4(X4)
    14         .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q
    15         .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN
    16         K ^TMP("ORXS1",$J),^TMP("ORXS2",$J)
    17         S FAC="",CNT=-1
    18         F  S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN=""  S NODE=^(IFN) D
    19         . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility
    20         . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time
    21         . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = ""
    22         . S IFN1=""
    23         . F  S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1=""  S IFN2="" F  S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2=""  S X=^(IFN2) D
    24         .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X) D METH(X)
    25         .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X) D METH(X)
    26         .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X) D METH(X)
    27         .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X) D METH(X)
    28         .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X) D METH(X)
    29         .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X) D METH(X)
    30         .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X) D METH(X)
    31         .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D
    32         ... D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X) D METH(X)
    33         ... F I=1:1:2 D
    34         .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["l/min" D XVSET("13^"_$P($P($P(X,"^",13),"|",I)," "),13,FAC,IFN,X) ;Flow Rate
    35         .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["%" D XVSET("14^"_$P($P($P(X,"^",13),"|",I)," "),14,FAC,IFN,X) ;O2 Concentration
    36         .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X) D METH(X)
    37         .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X) D METH(X)
    38         S FAC=""
    39         F  S FAC=$O(^TMP("ORXS2",$J,"METH",FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS2",$J,"METH",FAC,IFN)) Q:IFN=""  S METHOD=^(IFN,1),DATA=^(0) D
    40         .I $L(METHOD) S X=METHOD D
    41         .. D XVSET("16^"_X,16,FAC,IFN,DATA) ;Methods
    42         S FAC=""
    43         F  S FAC=$O(^TMP("ORXS2",$J,"QUAL",FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS2",$J,"QUAL",FAC,IFN)) Q:IFN=""  S QUALIF=^(IFN,1),DATA=^(0) D
    44         .I $L(QUALIF) S X=QUALIF D
    45         .. D XVSET("15^"_X,15,FAC,IFN,DATA) ;Qualifiers
    46         S FAC=""
    47         F  S FAC=$O(^TMP("ORXS2",$J,"UNIT",FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS2",$J,"UNIT",FAC,IFN)) Q:IFN=""  S UNIT=^(IFN,1),DATA=^(0) D
    48         .I $L(UNIT) S X=UNIT D
    49         .. D XVSET("17^"_X,17,FAC,IFN,DATA) ;Units
    50         K ^XTMP(HANDLE,"D")
    51         S FAC="",CNT=-1
    52         F  S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN=""  S IFN1="" D
    53         . F  S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1=""  S X=^(IFN1) D
    54         .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X
    55         K ^TMP("ORXS",$J),^TMP("ORXS1",$J),^TMP("ORXS2",$J)
    56         Q
    57 METH(DATA)      ;Get Methods, Units & Qualifiers
    58         Q:'$D(DATA)
    59         N X,D,T
    60         S X=$P($P(DATA,"^",3),"~",2),D=$P($G(DATA),"^",4),T=$P($P(DATA,"^",5),"~",2)
    61         I $L(X),$L(T),$L(D) S METHOD=$G(^TMP("ORXS2",$J,"METH",FAC,IFN,1)),METHOD=$S($L(METHOD):METHOD_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"METH",FAC,IFN,1)=METHOD,^(0)=DATA
    62         S X=$P($P(DATA,"^",8),"~",2)
    63         I $L(X),$L(T),$L(D) S QUALIF=$G(^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)),QUALIF=$S($L(QUALIF):QUALIF_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)=QUALIF,^(0)=DATA
    64         S X=$P($P(DATA,"^",7),"~",2)
    65         I $L(X),$L(T),$L(D) S UNIT=$G(^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)),UNIT=$S($L(UNIT):UNIT_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)=UNIT,^(0)=DATA
    66         Q
    67 XVSET(X,IFN,FAC,IDT,NODE)       ;Setup Vitals nodes
    68         Q:'$D(X)  Q:'$L($G(IDT))
    69         N SAVE,OIDT
    70         S SAVE=X
    71         I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q
    72         I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D  Q  ;Get data where item, facility, date/time are the same
    73         . S OIDT=IDT
    74         . F  S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN))
    75         . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D
    76         .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility
    77         .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time
    78         . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT
    79         S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE)
    80         Q
     1ORWRP4V  ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05  13:21
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
     3VS ;Vitals code for HDR
     4 N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE
     5 K ^TMP("ORXS",$J)
     6 S IFN=""
     7 F  S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN=""  S XIFN=^(IFN) D
     8 . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12
     9 . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^")
     10 . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown")
     11 . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2)
     12 . I $P(XIFN,"^",10)'="W",$L(X5) D
     13 .. S X4=9999999-$$SETDATE^ORWRP4(X4)
     14 .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q
     15 .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN
     16 K ^TMP("ORXS1",$J)
     17 S FAC="",CNT=-1
     18 F  S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN=""  S NODE=^(IFN) D
     19 . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility
     20 . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time
     21 . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = ""
     22 . S IFN1=""
     23 . F  S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1=""  S IFN2="" F  S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2=""  S X=^(IFN2) D
     24 .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X)
     25 .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X)
     26 .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X)
     27 .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X)
     28 .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X)
     29 .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X)
     30 .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X)
     31 .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X)
     32 .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X)
     33 .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X)
     34 K ^XTMP(HANDLE,"D")
     35 S FAC="",CNT=-1
     36 F  S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC=""  S IFN="" F  S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN=""  S IFN1="" D
     37 . F  S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1=""  S X=^(IFN1) D
     38 .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X
     39 K ^TMP("ORXS",$J),^TMP("ORXS1",$J)
     40 Q
     41XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes
     42 Q:'$D(X)  Q:'$L($G(IDT))
     43 N SAVE,OIDT
     44 S SAVE=X
     45 I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q
     46 I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D  Q  ;Get data where item, facility, date/time are the same
     47 . S OIDT=IDT
     48 . F  S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN))
     49 . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D
     50 .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility
     51 .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time
     52 . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT
     53 S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE)
     54 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTIU.m

    r613 r623  
    1 ORWTIU  ; slc/REV - Functions for GUI PARAMETER ACTIONS ; 08 Feb 2001  09:02AM
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,195,243**;Dec 17, 1997;Build 242
    3         ;
    4 GTTIUCTX(Y,ORUSER)      ; Returns current Notes view context for user
    5         N OCCLIM,SHOWSUB
    6         S Y=$$GET^XPAR("ALL","ORCH CONTEXT NOTES",1)
    7         I +$P(Y,";",5)=0 D
    8         . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10)
    9         . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM
    10         S SHOWSUB=$P(Y,";",6)
    11         S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0)
    12         Q
    13 SVTIUCTX(Y,ORCTXT)      ; Save new Notes view preferences for user
    14         N TMP
    15         S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1)
    16         I TMP'="" D  Q
    17         . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT)
    18         D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT)
    19         Q
    20         ;
    21 GTDCCTX(Y,ORUSER)       ; Returns current DC Summary view context for user
    22         N OCCLIM,SHOWSUB
    23         S Y=$$GET^XPAR("ALL","ORCH CONTEXT SUMMRIES",1)
    24         I +$P(Y,";",5)=0 D
    25         . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10)
    26         . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM
    27         S SHOWSUB=$P(Y,";",6)
    28         S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0)
    29         Q
    30 SVDCCTX(Y,ORCTXT)       ; Save new DC Summary view preferences for user
    31         N TMP
    32         S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1)
    33         I TMP'="" D  Q
    34         . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT)
    35         D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT)
    36         Q
    37         ;
    38 PRINTW(ORY,ORDA,ORFLG)  ;TIU print to windows printer
    39         N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE
    40         N IOM,IOSL,IOST,IOF,IOT,IOS
    41         S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="ORWTIU"
    42         S ORY=$NA(^TMP(ORSUB,$J,1))
    43         S ORHFS=$$HFS^ORWRP()
    44         D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
    45         I POP D  Q
    46         . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for TIU print")
    47         D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
    48         N $ETRAP,$ESTACK
    49         S $ETRAP="D ERR^ORWRP Q"
    50         U IO
    51         D RPC^TIUPD(.ORERR,ORDA,ORIO,ORFLG,ORWIN)
    52         D HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
    53         Q
    54 GTLSTITM(ORY,ORTIUDA)   ; Return single listbox item for document
    55         Q:+$G(ORTIUDA)=0
    56         S ORY=ORTIUDA_U_$$RESOLVE^TIUSRVLO(ORTIUDA)
    57         Q
    58 IDNOTES(ORY)       ; Is ID Notes installed?
    59         S ORY=$$PATCH^XPDUTL("TIU*1.0*100")
    60         Q
    61 CANLINK(ORY,ORTITLE)       ;Can the title be an ID child?
    62         ; DBIA #2322
    63         S ORY=$$CANLINK^TIULP(ORTITLE)
    64         Q
    65 GETCP(ORY,ORTIUDA)      ; Checks required CP fields before signature
    66         S ORY=""
    67         N ORTITLE,ORAUTH,ORCOS,ORPSUMCD,ORPROCDT,ORROOT,ORERR,ORREFDT
    68         S ORERR="",ORROOT=$NA(^TMP("ORTIU",$J))
    69         D EXTRACT^TIULQ(ORTIUDA,.ORROOT,.ORERR,".01;1202;1208;70201;70202;1301",,,"I")
    70         S ORTITLE=@ORROOT@(ORTIUDA,".01","I")
    71         S ORAUTH=@ORROOT@(ORTIUDA,"1202","I")
    72         S ORCOS=@ORROOT@(ORTIUDA,"1208","I")
    73         S ORPSUMCD=@ORROOT@(ORTIUDA,"70201","I")
    74         S ORPROCDT=@ORROOT@(ORTIUDA,"70202","I")
    75         S ORREFDT=@ORROOT@(ORTIUDA,"1301","I")
    76         S ORY=ORAUTH_U_ORCOS_U_ORPSUMCD_U_ORPROCDT_U_ORTITLE_U_ORREFDT
    77         K @ORROOT
    78         Q
    79 CHKTXT(ORY,ORTIUDA)     ; Checks for presence of text before signature
    80         S ORY='$$EMPTYDOC^TIULF(ORTIUDA)  ;DBIA #4426
    81         Q
     1ORWTIU ; slc/REV - Functions for GUI PARAMETER ACTIONS ; 08 Feb 2001  09:02AM
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,195**;Dec 17, 1997
     3 ;
     4GTTIUCTX(Y,ORUSER) ; Returns current Notes view context for user
     5 N OCCLIM,SHOWSUB
     6 S Y=$$GET^XPAR("ALL","ORCH CONTEXT NOTES",1)
     7 I +$P(Y,";",5)=0 D
     8 . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10)
     9 . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM
     10 S SHOWSUB=$P(Y,";",6)
     11 S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0)
     12 Q
     13SVTIUCTX(Y,ORCTXT) ; Save new Notes view preferences for user
     14 N TMP
     15 S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1)
     16 I TMP'="" D  Q
     17 . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT)
     18 D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT)
     19 Q
     20 ;
     21GTDCCTX(Y,ORUSER) ; Returns current DC Summary view context for user
     22 N OCCLIM,SHOWSUB
     23 S Y=$$GET^XPAR("ALL","ORCH CONTEXT SUMMRIES",1)
     24 I +$P(Y,";",5)=0 D
     25 . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10)
     26 . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM
     27 S SHOWSUB=$P(Y,";",6)
     28 S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0)
     29 Q
     30SVDCCTX(Y,ORCTXT) ; Save new DC Summary view preferences for user
     31 N TMP
     32 S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1)
     33 I TMP'="" D  Q
     34 . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT)
     35 D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT)
     36 Q
     37 ;
     38PRINTW(ORY,ORDA,ORFLG) ;TIU print to windows printer
     39 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE
     40 N IOM,IOSL,IOST,IOF,IOT,IOS
     41 S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="ORWTIU"
     42 S ORY=$NA(^TMP(ORSUB,$J,1))
     43 S ORHFS=$$HFS^ORWRP()
     44 D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
     45 I POP D  Q
     46 . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for TIU print")
     47 D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
     48 N $ETRAP,$ESTACK
     49 S $ETRAP="D ERR^ORWRP Q"
     50 U IO
     51 D RPC^TIUPD(.ORERR,ORDA,ORIO,ORFLG,ORWIN)
     52 D HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
     53 Q
     54GTLSTITM(ORY,ORTIUDA) ; Return single listbox item for document
     55 Q:+$G(ORTIUDA)=0
     56 S ORY=ORTIUDA_U_$$RESOLVE^TIUSRVLO(ORTIUDA)
     57 Q
     58IDNOTES(ORY)    ; Is ID Notes installed?
     59 S ORY=$$PATCH^XPDUTL("TIU*1.0*100")
     60 Q
     61CANLINK(ORY,ORTITLE)    ;Can the title be an ID child?
     62 ; DBIA #2322
     63 S ORY=$$CANLINK^TIULP(ORTITLE)
     64 Q
     65GETCP(ORY,ORTIUDA) ; Checks required CP fields before signature
     66 S ORY=""
     67 N ORTITLE,ORAUTH,ORCOS,ORPSUMCD,ORPROCDT,ORROOT,ORERR
     68 S ORERR="",ORROOT=$NA(^TMP("ORTIU",$J))
     69 D EXTRACT^TIULQ(ORTIUDA,.ORROOT,.ORERR,".01;1202;1208;70201;70202",,,"I")
     70 S ORTITLE=@ORROOT@(ORTIUDA,".01","I")
     71 S ORAUTH=@ORROOT@(ORTIUDA,"1202","I")
     72 S ORCOS=@ORROOT@(ORTIUDA,"1208","I")
     73 S ORPSUMCD=@ORROOT@(ORTIUDA,"70201","I")
     74 S ORPROCDT=@ORROOT@(ORTIUDA,"70202","I")
     75 S ORY=ORAUTH_U_ORCOS_U_ORPSUMCD_U_ORPROCDT_U_ORTITLE
     76 K @ORROOT
     77 Q
     78CHKTXT(ORY,ORTIUDA) ; Checks for presence of text before signature
     79 S ORY='$$EMPTYDOC^TIULF(ORTIUDA)  ;DBIA #4426
     80 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPD.m

    r613 r623  
    1 ORWTPD  ; slc/jdl - Personal Reference Tool ;6/20/02 11:40am [7/22/03 11:27am]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,148,141,173,195,243**;Dec 17,1997;Build 242
    3         ;; Allow user to customize the CPRS reports date/time
    4         ;; and max occurences setting
    5         ;
    6 SUDF(Y,VALUE)   ;----Set user default for all CPRS reports
    7         N ORERR S ORERR=""
    8         I VALUE=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) K ORERR Q
    9         E  D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,VALUE,.ORERR)
    10         S Y=1
    11         K ORERR,VALUES1
    12         Q
    13         ;
    14 SUINDV(Y,RPTS,VALUE)    ;----Set user individual time/occ setting
    15         ; RPTS format: RPTIen^RPTIen^RPTIen such as 1^2^3
    16         I $L(RPTS)=0 Q
    17         N ORERR,RPTID,P1,P7 S ORERR=0
    18         S (P1,P7)=""
    19         F I=1:1:$L(RPTS,"^") S RPTID=$P(RPTS,U,I) D
    20         . S P1=$P($G(^ORD(101.24,RPTID,0)),U),P7=$P($G(^(0)),U,7)
    21         . I "02345"[P7,(P1'="ORRP IMAGING") D DEL^XPAR("USR.`"_DUZ,"ORWRP TIME/OCC LIMITS INDV",RPTID,.ORERR) Q
    22         . D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",RPTID,VALUE,.ORERR)
    23         Q
    24         ;
    25 GETIMG(Y,RPT)   ; ----Get Image (local only) Time/Occ
    26         N IMGID,BEG,END,MAX
    27         S IMGID=0,Y=""
    28         S IMGID=$O(^ORD(101.24,"B","ORRP IMAGING",0))
    29         D GETINDV(.Y,IMGID)
    30         I $L(Y) D
    31         . S BEG=$$DT^ORCHTAB1($P(Y,";"))
    32         . S END=$$DT^ORCHTAB1($P(Y,";",2))
    33         . S MAX=$P(Y,";",3)
    34         . S Y=BEG_"^"_END_"^"_MAX
    35         I Y="" D GETDEF^ORWRA(.Y)
    36         Q
    37         ;
    38 GETINDV(Y,RPT)  ;----Get time/occ limits for this report
    39         ;RPT:  Report IEN of 101.24
    40         N CTX,X0,X4,X,IMGCTX
    41         S X0=$G(^ORD(101.24,RPT,0)),X4=$G(^(4))
    42         I "02345"[($P(X0,U,7)),($P(X0,U)'="ORRP IMAGING") Q
    43         S CTX="^DIV^SYS^PKG"
    44         S Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS INDV",RPT,"I")
    45         S:'$L(Y) Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS ALL",1,"I")
    46         I $P(^ORD(101.24,RPT,0),U,7)=1 S $P(Y,";",3)=""
    47         I $P(X4,"^",2) S X=$P($P(Y,";"),"-",2) I X,X>$P(X4,"^",2) S Y="T-"_$P(X4,"^",2)_";"_$P(Y,";",2,99)
    48         Q
    49         ;
    50 GETSETS(Y)      ;----Get time/occ limit set for each report
    51         N I,CNT,CAT,SEC
    52         S I=0,CNT=1,RST=""
    53         F  S I=$O(^ORD(101.24,I)) Q:'I   D
    54         . I $P($G(^ORD(101.24,I,0)),U,12)'="M" D
    55         .. S CAT=$P(^ORD(101.24,I,0),U,7),SEC=$P(^(0),U,8)
    56         .. I $S(CAT=1:1,CAT=6:1,1:0)!($P(^(0),U)="ORRP IMAGING") D
    57         ... D GETINDV(.RST,I)
    58         ... I $L($P(^ORD(101.24,I,2),U,4))>0 S Y(CNT)=I_U_$P(^(2),U,4)_" ["_SEC_"]"_U_RST
    59         ... E  S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,3)_" ["_SEC_"]"_U_RST
    60         ... S CNT=CNT+1
    61         K I,CNT,RST,CAT
    62         Q
    63         ;
    64 GETDFLT(Y)      ;----Get default time/occ limits for all reports
    65         N VALUE
    66         S Y=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
    67         K VALUE
    68         Q
    69         ;
    70 RSDFLT(Y)       ;----Retrieve sys/pkg level default time/occ setting
    71         N VALUE
    72         S Y=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
    73         Q
    74         ;
    75 DELDFLT(Y)      ;----Delete user's default setting
    76         N ORERR S ORERR=""
    77         D NDEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",.ORERR)
    78         D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR)
    79         K ORERR
    80         Q
    81         ;
    82 ACTDF(Y)        ;----Make default setting take action for each report
    83         N IND,DFLT,VALUE,X,X0,X4,MAX,DFLT1
    84         S DFLT=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
    85         S IND=0,X=$P($P(DFLT,";"),"-",2)
    86         F  S IND=$O(^ORD(101.24,IND)) Q:'IND  S X0=$G(^(IND,0)),X4=$G(^(4)) D
    87         . I $P(X0,"^",8)="R",$P(X0,"^",12)'="M" D
    88         .. S MAX=$P(X4,"^",2),DFLT1=DFLT
    89         .. I MAX,X,X>MAX S DFLT1="T-"_MAX_";"_$P(DFLT,";",2,99)
    90         .. D SUINDV(.Y,IND,DFLT1)
    91         Q
    92 GETOCM(ORY)     ;Get value of "ORCH CONTEXT MEDS"
    93         S ORY=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
    94         Q
    95         ;
    96 PUTOCM(ORY,ORVAL)       ;Set value of "ORCH CONTEXT MEDS"
    97         I '$L(ORVAL) D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS",1) Q
    98         N ORERR S ORERR=""
    99         D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT MEDS",1,ORVAL,.ORERR)
    100         S ORY=ORERR
    101         Q
    102         ;
     1ORWTPD ; slc/jdl - Personal Reference Tool ;6/20/02 11:40am [7/22/03 11:27am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,148,141,173,195**;Dec 17,1997
     3 ;; Allow user to customize the CPRS reports date/time
     4 ;; and max occurences setting
     5 ;
     6SUDF(Y,VALUE) ;----Set user default for all CPRS reports
     7 N ORERR S ORERR=""
     8 I VALUE=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) K ORERR Q
     9 E  D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,VALUE,.ORERR)
     10 S Y=1
     11 K ORERR,VALUES1
     12 Q
     13 ;
     14SUINDV(Y,RPTS,VALUE) ;----Set user individual time/occ setting
     15 ; RPTS format: RPTIen^RPTIen^RPTIen such as 1^2^3
     16 I $L(RPTS)=0 Q
     17 N ORERR,RPTID,P1,P7 S ORERR=0
     18 S (P1,P7)=""
     19 F I=1:1:$L(RPTS,"^") S RPTID=$P(RPTS,U,I) D
     20 . S P1=$P($G(^ORD(101.24,RPTID,0)),U),P7=$P($G(^(0)),U,7)
     21 . I "02345"[P7,(P1'="ORRP IMAGING") D DEL^XPAR("USR.`"_DUZ,"ORWRP TIME/OCC LIMITS INDV",RPTID,.ORERR) Q
     22 . D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",RPTID,VALUE,.ORERR)
     23 Q
     24 ;
     25GETIMG(Y,RPT) ; ----Get Image (local only) Time/Occ
     26 N IMGID,BEG,END,MAX
     27 S IMGID=0,Y=""
     28 S IMGID=$O(^ORD(101.24,"B","ORRP IMAGING",0))
     29 D GETINDV(.Y,IMGID)
     30 I $L(Y) D
     31 . S BEG=$$DT^ORCHTAB1($P(Y,";"))
     32 . S END=$$DT^ORCHTAB1($P(Y,";",2))
     33 . S MAX=$P(Y,";",3)
     34 . S Y=BEG_"^"_END_"^"_MAX
     35 I Y="" D GETDEF^ORWRA(.Y)
     36 Q
     37 ;
     38GETINDV(Y,RPT) ;----Get time/occ limits for this report
     39 ;RPT:  Report IEN of 101.24
     40 N CTX,X0,X4,X,IMGCTX
     41 S X0=$G(^ORD(101.24,RPT,0)),X4=$G(^(4))
     42 I "02345"[($P(X0,U,7)),($P(X0,U)'="ORRP IMAGING") Q
     43 S CTX="^DIV^SYS^PKG"
     44 S Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS INDV",RPT,"I")
     45 S:'$L(Y) Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS ALL",1,"I")
     46 I $P(^ORD(101.24,RPT,0),U,7)=1 S $P(Y,";",3)=""
     47 I $P(X4,"^",2) S X=$P($P(Y,";"),"-",2) I X,X>$P(X4,"^",2) S Y="T-"_$P(X4,"^",2)_";"_$P(Y,";",2,99)
     48 Q
     49 ;
     50GETSETS(Y) ;----Get time/occ limit set for each report
     51 N I,CNT,CAT S I=0,CNT=1,RST=""
     52 F  S I=$O(^ORD(101.24,I)) Q:'I   D
     53 .I $P($G(^ORD(101.24,I,0)),U,8)="R",$P($G(^ORD(101.24,I,0)),U,12)'="M" D
     54 ..S CAT=$P(^ORD(101.24,I,0),U,7) I $S(CAT=1:1,CAT=6:1,1:0)!($P(^(0),U)="ORRP IMAGING") D
     55 ...D GETINDV(.RST,I)
     56 ...I $L($P(^ORD(101.24,I,2),U,4))>0 S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,4)_U_RST
     57 ...E  S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,3)_U_RST
     58 ... S CNT=CNT+1
     59 K I,CNT,RST,CAT
     60 Q
     61 ;
     62GETDFLT(Y) ;----Get default time/occ limits for all reports
     63 N VALUE
     64 S Y=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
     65 K VALUE
     66 Q
     67 ;
     68RSDFLT(Y) ;----Retrieve sys/pkg level default time/occ setting
     69 N VALUE
     70 S Y=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
     71 Q
     72 ;
     73DELDFLT(Y) ;----Delete user's default setting
     74 N ORERR S ORERR=""
     75 D NDEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",.ORERR)
     76 D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR)
     77 K ORERR
     78 Q
     79 ;
     80ACTDF(Y) ;----Make default setting take action for each report
     81 N IND,DFLT,VALUE,X,X0,X4,MAX,DFLT1
     82 S DFLT=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I")
     83 S IND=0,X=$P($P(DFLT,";"),"-",2)
     84 F  S IND=$O(^ORD(101.24,IND)) Q:'IND  S X0=$G(^(IND,0)),X4=$G(^(4)) D
     85 . I $P(X0,"^",8)="R",$P(X0,"^",12)'="M" D
     86 .. S MAX=$P(X4,"^",2),DFLT1=DFLT
     87 .. I MAX,X,X>MAX S DFLT1="T-"_MAX_";"_$P(DFLT,";",2,99)
     88 .. D SUINDV(.Y,IND,DFLT1)
     89 Q
     90GETOCM(ORY) ;Get value of "ORCH CONTEXT MEDS"
     91 S ORY=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
     92 Q
     93 ;
     94PUTOCM(ORY,ORVAL) ;Set value of "ORCH CONTEXT MEDS"
     95 I '$L(ORVAL) D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS",1) Q
     96 N ORERR S ORERR=""
     97 D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT MEDS",1,ORVAL,.ORERR)
     98 S ORY=ORERR
     99 Q
     100 ;

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPL.m

    r613 r623  
    1 ORWTPL  ; SLC/STAFF Personal Preference - Lists ; 3/11/08 6:36am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173,243**;Oct 24, 2000;Build 242
    3         ;
    4 NEWLIST(VAL,LISTNAME,USER,ORVIZ)        ; from ORWTPP
    5         ; set user's new personal list
    6         S LISTNAME=$G(LISTNAME)
    7         I '$L(LISTNAME) S VAL="^invalid list name" Q
    8         I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q
    9         ;*** check input transform, duplicate name for same user
    10         N DA,DIK,NUM
    11         L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q
    12         S NUM=1+$P(^OR(100.21,0),U,3)
    13         F  Q:'$D(^OR(100.21,NUM,0))  S NUM=NUM+1
    14         S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1
    15         S ^OR(100.21,NUM,0)=LISTNAME_"^P"
    16         L -^OR(100.21,0)
    17         K ^OR(100.21,NUM,1),^(2),^(10)
    18         S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1"
    19         S ^OR(100.21,NUM,1,USER,0)=USER
    20         S ^OR(100.21,NUM,11)=$G(ORVIZ)_U
    21         S DIK="^OR(100.21,",DA=NUM
    22         D IX1^DIK
    23         S VAL=NUM_U_LISTNAME_"^^^^^^^"_$G(ORVIZ)
    24         Q
    25         ;
    26 DELLIST(OK,LISTNUM,USER)        ; from ORWTPP
    27         ; delete user's personal list
    28         N DA,DIK
    29         S LISTNUM=+$G(LISTNUM),OK=1
    30         I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q
    31         I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q
    32         S DA=LISTNUM,DIK="^OR(100.21,"
    33         D ^DIK
    34         Q
    35         ;
    36 SAVELIST(OK,PLIST,LISTNUM,USER,ORVIZ)   ; from ORWTPP
    37         ; save user's personal list changes
    38         N CNT,DA,DFN,DIK,NUM K DA
    39         S LISTNUM=+$G(LISTNUM),OK=1
    40         I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q
    41         I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q
    42         I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^"
    43         S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10,"
    44         S DA=0 F  S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1  D ^DIK
    45         K DA
    46         S CNT=0
    47         S NUM=0 F  S NUM=$O(PLIST(NUM)) Q:NUM<1  D
    48         .S DFN=+PLIST(NUM) I 'DFN Q
    49         .S CNT=CNT+1
    50         .S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT("
    51         S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT
    52         S ^OR(100.21,LISTNUM,11)=$G(ORVIZ)_U
    53         S DA=LISTNUM,DIK="^OR(100.21,"
    54         D IX1^DIK
    55         Q
    56         ;
    57 LSDEF(INFO,USER)        ; from ORWTPP
    58         ; get user's list sources
    59         N TYPE
    60         S INFO=""
    61         F TYPE="P","S","T","W","C" D
    62         .S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U
    63         Q
    64         ;
    65 SORTDEF(SORT,USER)      ; from ORWTPP
    66         ; get user's sort order - Modified by PKS - 8/30/2001
    67         N ORSECT
    68         S ORSECT=$G(^VA(200,USER,5))
    69         I +ORSECT>0 S ORSECT=$P(ORSECT,U)
    70         S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A"
    71         Q
    72         ;
    73 CLDAYS(DAYS,USER)       ; from ORWTPP
    74         ; get user's clinic defaults
    75         N DAY
    76         S DAYS=""
    77         F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D
    78         .S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U
    79         Q
    80         ;
    81 CLRANGE(RANGE,USER)     ; from ORWTPP
    82         ; get user's default clinic start, stop dates
    83         N RNG
    84         S RANGE=""
    85         F RNG="START","STOP" D
    86         .S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U
    87         Q
    88         ;
    89 SAVECD(OK,INFO,USER)    ; from ORWTPP
    90         ; save user's clinic defaults
    91         N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED
    92         S OK=1
    93         S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START)
    94         S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP)
    95         S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON)
    96         S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES)
    97         S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED)
    98         S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS)
    99         S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI)
    100         S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT)
    101         S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN)
    102         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START)
    103         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP)
    104         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON)
    105         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES)
    106         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED)
    107         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS)
    108         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI)
    109         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT)
    110         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN)
    111         Q
    112         ;
    113 SAVEPLD(OK,INFO,USER)   ; from ORWTPP
    114         ; save user's clinic defaults
    115         N PROV,SORT,SOURCE,SPEC,TEAM,WARD
    116         S OK=1
    117         S SOURCE=$P(INFO,U,1)
    118         S SORT=$P(INFO,U,2)
    119         S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV)
    120         S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC)
    121         S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM)
    122         S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD)
    123         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE)
    124         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT)
    125         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV)
    126         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC)
    127         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM)
    128         D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD)
    129         Q
     1ORWTPL ; SLC/STAFF Personal Preference - Lists ;4/30/01  11:04 [5/19/03 3:11pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173**;Oct 24, 2000
     3 ;
     4NEWLIST(VAL,LISTNAME,USER) ; from ORWTPP
     5 ; set user's new personal list
     6 S LISTNAME=$G(LISTNAME)
     7 I '$L(LISTNAME) S VAL="^invalid list name" Q
     8 I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q
     9 ;*** check input transform, duplicate name for same user
     10 N DA,DIK,NUM
     11 L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q
     12 S NUM=1+$P(^OR(100.21,0),U,3)
     13 F  Q:'$D(^OR(100.21,NUM,0))  S NUM=NUM+1
     14 S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1
     15 S ^OR(100.21,NUM,0)=LISTNAME_"^P"
     16 L -^OR(100.21,0)
     17 K ^OR(100.21,NUM,1),^(2),^(10)
     18 S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1"
     19 S ^OR(100.21,NUM,1,USER,0)=USER
     20 S DIK="^OR(100.21,",DA=NUM
     21 D IX1^DIK
     22 S VAL=NUM_U_LISTNAME
     23 Q
     24 ;
     25DELLIST(OK,LISTNUM,USER) ; from ORWTPP
     26 ; delete user's personal list
     27 N DA,DIK
     28 S LISTNUM=+$G(LISTNUM),OK=1
     29 I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q
     30 I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q
     31 S DA=LISTNUM,DIK="^OR(100.21,"
     32 D ^DIK
     33 Q
     34 ;
     35SAVELIST(OK,PLIST,LISTNUM,USER) ; from ORWTPP
     36 ; save user's personal list changes
     37 N CNT,DA,DFN,DIK,NUM K DA
     38 S LISTNUM=+$G(LISTNUM),OK=1
     39 I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q
     40 I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q
     41 I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^"
     42 S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10,"
     43 S DA=0 F  S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1  D ^DIK
     44 K DA
     45 S CNT=0
     46 S NUM=0 F  S NUM=$O(PLIST(NUM)) Q:NUM<1  D
     47 .S DFN=+PLIST(NUM) I 'DFN Q
     48 .S CNT=CNT+1
     49 .S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT("
     50 S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT
     51 S DA=LISTNUM,DIK="^OR(100.21,"
     52 D IX1^DIK
     53 Q
     54 ;
     55LSDEF(INFO,USER) ; from ORWTPP
     56 ; get user's list sources
     57 N TYPE
     58 S INFO=""
     59 F TYPE="P","S","T","W","C" D
     60 .S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U
     61 Q
     62 ;
     63SORTDEF(SORT,USER) ; from ORWTPP
     64 ; get user's sort order - Modified by PKS - 8/30/2001
     65 N ORSECT
     66 S ORSECT=$G(^VA(200,USER,5))
     67 I +ORSECT>0 S ORSECT=$P(ORSECT,U)
     68 S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A"
     69 Q
     70 ;
     71CLDAYS(DAYS,USER) ; from ORWTPP
     72 ; get user's clinic defaults
     73 N DAY
     74 S DAYS=""
     75 F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D
     76 .S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U
     77 Q
     78 ;
     79CLRANGE(RANGE,USER) ; from ORWTPP
     80 ; get user's default clinic start, stop dates
     81 N RNG
     82 S RANGE=""
     83 F RNG="START","STOP" D
     84 .S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U
     85 Q
     86 ;
     87SAVECD(OK,INFO,USER) ; from ORWTPP
     88 ; save user's clinic defaults
     89 N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED
     90 S OK=1
     91 S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START)
     92 S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP)
     93 S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON)
     94 S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES)
     95 S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED)
     96 S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS)
     97 S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI)
     98 S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT)
     99 S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN)
     100 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START)
     101 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP)
     102 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON)
     103 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES)
     104 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED)
     105 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS)
     106 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI)
     107 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT)
     108 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN)
     109 Q
     110 ;
     111SAVEPLD(OK,INFO,USER) ; from ORWTPP
     112 ; save user's clinic defaults
     113 N PROV,SORT,SOURCE,SPEC,TEAM,WARD
     114 S OK=1
     115 S SOURCE=$P(INFO,U,1)
     116 S SORT=$P(INFO,U,2)
     117 S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV)
     118 S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC)
     119 S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM)
     120 S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD)
     121 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE)
     122 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT)
     123 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV)
     124 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC)
     125 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM)
     126 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD)
     127 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPP.m

    r613 r623  
    1 ORWTPP  ; SLC/STAFF Personal Preference - Personal ; 3/11/08 6:34am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,243**;Oct 24, 2000;Build 242
    3         ;
    4 NEWLIST(VAL,LISTNAME,ORVIZ)     ; RPC
    5         ; set current user's new personal list
    6         D NEWLIST^ORWTPL(.VAL,LISTNAME,DUZ,$G(ORVIZ))
    7         Q
    8         ;
    9 DELLIST(OK,LISTNUM)     ; RPC
    10         ; delete current user's personal list
    11         D DELLIST^ORWTPL(.OK,LISTNUM,DUZ)
    12         Q
    13         ;
    14 SAVELIST(OK,PLIST,LISTNUM,ORVIZ)        ; RPC
    15         ; save current user's personal list changes
    16         D SAVELIST^ORWTPL(.OK,.PLIST,LISTNUM,DUZ,$G(ORVIZ))
    17         Q
    18         ;
    19 LSDEF(INFO)     ; RPC
    20         ; get current user's list sources
    21         D LSDEF^ORWTPL(.INFO,DUZ)
    22         Q
    23         ;
    24 SORTDEF(VALUE)  ; RPC
    25         ; get current user's sort order
    26         D SORTDEF^ORWTPL(.VALUE,DUZ)
    27         Q
    28         ;
    29 CLDAYS(INFO)    ; RPC
    30         ; get current user's clinic defaults
    31         D CLDAYS^ORWTPL(.INFO,DUZ)
    32         Q
    33         ;
    34 CLRANGE(INFO)   ; RPC
    35         ; get current user's default clinic start, stop dates
    36         D CLRANGE^ORWTPL(.INFO,DUZ)
    37         Q
    38         ;
    39 SAVECD(OK,INFO) ; RPC
    40         ; save current user's clinic defaults
    41         D SAVECD^ORWTPL(.OK,INFO,DUZ)
    42         Q
    43         ;
    44 SAVEPLD(OK,INFO)        ; RPC
    45         ; save current user's list selection defaults
    46         D SAVEPLD^ORWTPL(.OK,INFO,DUZ)
    47         Q
    48         ;
    49 CSLAB(INFO)     ; RPC
    50         ; get lab date range defaults
    51         D CSLAB^ORWTPO(.INFO,DUZ)
    52         Q
    53         ;
    54 CSARNG(INFO)    ; RPC
    55         ; get current user's start, stop defaults
    56         D CSARNG^ORWTPO(.INFO,DUZ)
    57         Q
    58         ;
    59 SAVECS(OK,INFO) ; RPC
    60         ; save current user's date range defaults
    61         D SAVECS^ORWTPO(.OK,INFO,DUZ)
    62         Q
    63         ;
    64 GETIMG(INFO)    ; RPC
    65         ; get current user's image report defaults
    66         D GETIMG^ORWTPO(.INFO,DUZ)
    67         Q
    68         ;
    69 SETIMG(OK,MAX,START,STOP)       ; RPC
    70         ; save current user's image report defaults
    71         D SETIMG^ORWTPO(.OK,MAX,START,STOP,DUZ)
    72         Q
    73         ;
    74 GETREM(VALUES)  ; RPC
    75         ; get current user's reminders
    76         D GETREM^ORWTPR(.VALUES,DUZ)
    77         Q
    78         ;
    79 SETREM(OK,VALUES)       ; RPC
    80         ; set current user's reminders
    81         D SETREM^ORWTPR(.OK,.VALUES,DUZ)
    82         Q
    83         ;
    84 GETOC(VALUES)   ; RPC
    85         ; get current user's order checks
    86         D GETOC^ORWTPR(.VALUES,DUZ)
    87         Q
    88         ;
    89 SAVEOC(OK,VALUES)       ; RPC
    90         ; save current user's order checks
    91         D SAVEOC^ORWTPR(.OK,.VALUES,DUZ)
    92         Q
    93         ;
    94 GETNOT(VALUES)  ; RPC
    95         ; get current user's notifications
    96         D GETNOT^ORWTPR(.VALUES,DUZ)
    97         Q
    98         ;
    99 SAVENOT(OK,VALUES)      ; RPC
    100         ; save current user's notifications
    101         D SAVENOT^ORWTPR(.OK,.VALUES,DUZ)
    102         Q
    103         ;
    104 CLEARNOT(OK)    ; RPC
    105         ; clear current user's notifications
    106         D CLEARNOT^ORWTPR(.OK,DUZ)
    107         Q
    108         ;
    109 GETNOTO(INFO)   ; RPC
    110         ; get current user's other info for notifications
    111         D GETNOTO^ORWTPR(.INFO,DUZ)
    112         Q
    113         ;
    114 CHKSURR(OK,SURR)        ; RPC
    115         ; check if current user's surrogate is valid
    116         S OK=$$CHKSURR^ORWTPUA(DUZ,SURR)
    117         Q
    118         ;
    119 GETSURR(INFO)   ; RPC
    120         ; get current user's surrogate info
    121         D GETSURR^ORWTPR(.INFO,DUZ)
    122         Q
    123         ;
    124 SAVESURR(OK,INFO)       ; RPC
    125         ; save current user's surrogate info
    126         D SAVESURR^ORWTPR(.OK,INFO,DUZ)
    127         Q
    128         ;
    129 SAVENOTO(OK,INFO)       ; RPC
    130         ; save current user's notification info
    131         D SAVENOTO^ORWTPR(.OK,INFO,DUZ)
    132         Q
    133         ;
    134 GETOTHER(INFO)  ; RPC
    135         ; get user's other parameter settings
    136         D GETOTHER^ORWTPO(.INFO,DUZ)
    137         Q
    138         ;
    139 SETOTHER(OK,INFO)       ; RPC
    140         ; set current user's other parameter settings
    141         D SETOTHER^ORWTPO(.OK,INFO,DUZ)
    142         Q
    143         ;
    144 GETSUB(VALUE)   ; RPC
    145         ; get Ask for Subject on notes for current user
    146         D GETSUB^ORWTPN(.VALUE,DUZ)
    147         Q
    148         ;
    149 GETCOS(VALUES,FROM,DIR,VISITORS)        ; RPC
    150         ; get elgible cosigners for current user
    151         I '$G(VISITORS) S VISITORS=""
    152         D GETCOS^ORWTPN(.VALUES,DUZ,FROM,DIR,VISITORS)
    153         Q
    154         ;
    155 GETDCOS(VALUE)  ; RPC
    156         ; get default cosigner for current user
    157         D GETDCOS^ORWTPN(.VALUE,DUZ)
    158         Q
    159         ;
    160 SETDCOS(OK,VALUE)       ; RPC
    161         ; set default cosigner for current user
    162         D SETDCOS^ORWTPN(.OK,VALUE,DUZ)
    163         Q
    164         ;
    165 SETSUB(OK,VALUE)        ; RPC
    166         ; set Ask for Subject on note for current user
    167         D SETSUB^ORWTPN(.OK,VALUE,DUZ)
    168         Q
    169         ;
    170 GETTU(VALUES,CLASS)     ; RPC
    171         ; get titles for current user
    172         D GETTU^ORWTPN(.VALUES,CLASS,DUZ)
    173         Q
    174         ;
    175 GETTD(VALUE,CLASS)      ; RPC
    176         ; get default title for current user
    177         D GETTD^ORWTPN(.VALUE,CLASS,DUZ)
    178         Q
    179         ;
    180 SAVET(OK,CLASS,DEFAULT,VALUES)  ; RPC
    181         ; save titles for current user
    182         D SAVET^ORWTPN(.OK,CLASS,DEFAULT,.VALUES,DUZ)
    183         Q
    184         ;
    185 PLISTS(VALUES)  ; RPC
    186         ; get current user's personal lists
    187         D PLISTS^ORWTPT(.VALUES,DUZ)
    188         Q
    189         ;
    190 PLTEAMS(VALUES) ; RPC
    191         ; get current user's teams and personal lists
    192         D PLTEAMS^ORWTPT(.VALUES,DUZ)
    193         Q
    194         ;
    195 TEAMS(VALUES)   ; RPC
    196         ; get teams for current user
    197         D TEAMS^ORWTPT(.VALUES,DUZ)
    198         Q
    199         ;
    200 ADDLIST(OK,VALUE)       ; RPC
    201         ; adds current user to a team
    202         D ADDLIST^ORWTPT(.OK,VALUE,DUZ)
    203         Q
    204         ;
    205 REMLIST(OK,VALUE)       ; RPC
    206         ; removes current user from a team
    207         D REMLIST^ORWTPT(.OK,VALUE,DUZ)
    208         Q
    209         ;
    210 GETCOMBO(VALUES)        ; RPC
    211         ; get current user's combo list definition
    212         D GETCOMBO^ORWTPT(.VALUES,DUZ)
    213         Q
    214         ;
    215 SETCOMBO(OK,VALUES)     ; RPC
    216         ; set current user's combo list definition
    217         D SETCOMBO^ORWTPT(.OK,.VALUES,DUZ)
    218         Q
     1ORWTPP ; SLC/STAFF Personal Preference - Personal ;1/19/01  15:30 [12/12/02 3:05pm]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149**;Oct 24, 2000
     3 ;
     4NEWLIST(VAL,LISTNAME) ; RPC
     5 ; set current user's new personal list
     6 D NEWLIST^ORWTPL(.VAL,LISTNAME,DUZ)
     7 Q
     8 ;
     9DELLIST(OK,LISTNUM) ; RPC
     10 ; delete current user's personal list
     11 D DELLIST^ORWTPL(.OK,LISTNUM,DUZ)
     12 Q
     13 ;
     14SAVELIST(OK,PLIST,LISTNUM) ; RPC
     15 ; save current user's personal list changes
     16 D SAVELIST^ORWTPL(.OK,.PLIST,LISTNUM,DUZ)
     17 Q
     18 ;
     19LSDEF(INFO) ; RPC
     20 ; get current user's list sources
     21 D LSDEF^ORWTPL(.INFO,DUZ)
     22 Q
     23 ;
     24SORTDEF(VALUE) ; RPC
     25 ; get current user's sort order
     26 D SORTDEF^ORWTPL(.VALUE,DUZ)
     27 Q
     28 ;
     29CLDAYS(INFO) ; RPC
     30 ; get current user's clinic defaults
     31 D CLDAYS^ORWTPL(.INFO,DUZ)
     32 Q
     33 ;
     34CLRANGE(INFO) ; RPC
     35 ; get current user's default clinic start, stop dates
     36 D CLRANGE^ORWTPL(.INFO,DUZ)
     37 Q
     38 ;
     39SAVECD(OK,INFO) ; RPC
     40 ; save current user's clinic defaults
     41 D SAVECD^ORWTPL(.OK,INFO,DUZ)
     42 Q
     43 ;
     44SAVEPLD(OK,INFO) ; RPC
     45 ; save current user's list selection defaults
     46 D SAVEPLD^ORWTPL(.OK,INFO,DUZ)
     47 Q
     48 ;
     49CSLAB(INFO) ; RPC
     50 ; get lab date range defaults
     51 D CSLAB^ORWTPO(.INFO,DUZ)
     52 Q
     53 ;
     54CSARNG(INFO) ; RPC
     55 ; get current user's start, stop defaults
     56 D CSARNG^ORWTPO(.INFO,DUZ)
     57 Q
     58 ;
     59SAVECS(OK,INFO) ; RPC
     60 ; save current user's date range defaults
     61 D SAVECS^ORWTPO(.OK,INFO,DUZ)
     62 Q
     63 ;
     64GETIMG(INFO) ; RPC
     65 ; get current user's image report defaults
     66 D GETIMG^ORWTPO(.INFO,DUZ)
     67 Q
     68 ;
     69SETIMG(OK,MAX,START,STOP) ; RPC
     70 ; save current user's image report defaults
     71 D SETIMG^ORWTPO(.OK,MAX,START,STOP,DUZ)
     72 Q
     73 ;
     74GETREM(VALUES) ; RPC
     75 ; get current user's reminders
     76 D GETREM^ORWTPR(.VALUES,DUZ)
     77 Q
     78 ;
     79SETREM(OK,VALUES) ; RPC
     80 ; set current user's reminders
     81 D SETREM^ORWTPR(.OK,.VALUES,DUZ)
     82 Q
     83 ;
     84GETOC(VALUES) ; RPC
     85 ; get current user's order checks
     86 D GETOC^ORWTPR(.VALUES,DUZ)
     87 Q
     88 ;
     89SAVEOC(OK,VALUES) ; RPC
     90 ; save current user's order checks
     91 D SAVEOC^ORWTPR(.OK,.VALUES,DUZ)
     92 Q
     93 ;
     94GETNOT(VALUES) ; RPC
     95 ; get current user's notifications
     96 D GETNOT^ORWTPR(.VALUES,DUZ)
     97 Q
     98 ;
     99SAVENOT(OK,VALUES) ; RPC
     100 ; save current user's notifications
     101 D SAVENOT^ORWTPR(.OK,.VALUES,DUZ)
     102 Q
     103 ;
     104CLEARNOT(OK) ; RPC
     105 ; clear current user's notifications
     106 D CLEARNOT^ORWTPR(.OK,DUZ)
     107 Q
     108 ;
     109GETNOTO(INFO) ; RPC
     110 ; get current user's other info for notifications
     111 D GETNOTO^ORWTPR(.INFO,DUZ)
     112 Q
     113 ;
     114CHKSURR(OK,SURR) ; RPC
     115 ; check if current user's surrogate is valid
     116 S OK=$$CHKSURR^ORWTPUA(DUZ,SURR)
     117 Q
     118 ;
     119GETSURR(INFO) ; RPC
     120 ; get current user's surrogate info
     121 D GETSURR^ORWTPR(.INFO,DUZ)
     122 Q
     123 ;
     124SAVESURR(OK,INFO) ; RPC
     125 ; save current user's surrogate info
     126 D SAVESURR^ORWTPR(.OK,INFO,DUZ)
     127 Q
     128 ;
     129SAVENOTO(OK,INFO) ; RPC
     130 ; save current user's notification info
     131 D SAVENOTO^ORWTPR(.OK,INFO,DUZ)
     132 Q
     133 ;
     134GETOTHER(INFO) ; RPC
     135 ; get user's other parameter settings
     136 D GETOTHER^ORWTPO(.INFO,DUZ)
     137 Q
     138 ;
     139SETOTHER(OK,INFO) ; RPC
     140 ; set current user's other parameter settings
     141 D SETOTHER^ORWTPO(.OK,INFO,DUZ)
     142 Q
     143 ;
     144GETSUB(VALUE) ; RPC
     145 ; get Ask for Subject on notes for current user
     146 D GETSUB^ORWTPN(.VALUE,DUZ)
     147 Q
     148 ;
     149GETCOS(VALUES,FROM,DIR,VISITORS) ; RPC
     150 ; get elgible cosigners for current user
     151 I '$G(VISITORS) S VISITORS=""
     152 D GETCOS^ORWTPN(.VALUES,DUZ,FROM,DIR,VISITORS)
     153 Q
     154 ;
     155GETDCOS(VALUE) ; RPC
     156 ; get default cosigner for current user
     157 D GETDCOS^ORWTPN(.VALUE,DUZ)
     158 Q
     159 ;
     160SETDCOS(OK,VALUE) ; RPC
     161 ; set default cosigner for current user
     162 D SETDCOS^ORWTPN(.OK,VALUE,DUZ)
     163 Q
     164 ;
     165SETSUB(OK,VALUE) ; RPC
     166 ; set Ask for Subject on note for current user
     167 D SETSUB^ORWTPN(.OK,VALUE,DUZ)
     168 Q
     169 ;
     170GETTU(VALUES,CLASS) ; RPC
     171 ; get titles for current user
     172 D GETTU^ORWTPN(.VALUES,CLASS,DUZ)
     173 Q
     174 ;
     175GETTD(VALUE,CLASS) ; RPC
     176 ; get default title for current user
     177 D GETTD^ORWTPN(.VALUE,CLASS,DUZ)
     178 Q
     179 ;
     180SAVET(OK,CLASS,DEFAULT,VALUES) ; RPC
     181 ; save titles for current user
     182 D SAVET^ORWTPN(.OK,CLASS,DEFAULT,.VALUES,DUZ)
     183 Q
     184 ;
     185PLISTS(VALUES) ; RPC
     186 ; get current user's personal lists
     187 D PLISTS^ORWTPT(.VALUES,DUZ)
     188 Q
     189 ;
     190PLTEAMS(VALUES) ; RPC
     191 ; get current user's teams and personal lists
     192 D PLTEAMS^ORWTPT(.VALUES,DUZ)
     193 Q
     194 ;
     195TEAMS(VALUES) ; RPC
     196 ; get teams for current user
     197 D TEAMS^ORWTPT(.VALUES,DUZ)
     198 Q
     199 ;
     200ADDLIST(OK,VALUE) ; RPC
     201 ; adds current user to a team
     202 D ADDLIST^ORWTPT(.OK,VALUE,DUZ)
     203 Q
     204 ;
     205REMLIST(OK,VALUE) ; RPC
     206 ; removes current user from a team
     207 D REMLIST^ORWTPT(.OK,VALUE,DUZ)
     208 Q
     209 ;
     210GETCOMBO(VALUES) ; RPC
     211 ; get current user's combo list definition
     212 D GETCOMBO^ORWTPT(.VALUES,DUZ)
     213 Q
     214 ;
     215SETCOMBO(OK,VALUES) ; RPC
     216 ; set current user's combo list definition
     217 D SETCOMBO^ORWTPT(.OK,.VALUES,DUZ)
     218 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPR.m

    r613 r623  
    1 ORWTPR  ; SLC/STAFF Personal Preference - Reminders ; 4/20/07 10:00am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,173,215,243**;Oct 24, 2000;Build 242
    3         ;
    4 GETREM(VALUES,USER)     ; from ORWTPP
    5         ; get user's reminders
    6         N CLASS,CNT,ERR,IEN,NUM,OK,TMPLIST,ZERO K VALUES
    7         D GETLST^XPAR(.TMPLIST,"USR.`"_USER,"ORQQPX SEARCH ITEMS","Q",.ERR)
    8         S CNT=0,IEN=0 F  S IEN=$O(^PXD(811.9,IEN)) Q:IEN<1  S ZERO=$G(^(IEN,0)) I $L($P(ZERO,U,3)),'$P(ZERO,U,6) D
    9         .S CNT=CNT+1
    10         .S VALUES(CNT)=IEN_"^0^"_$P(ZERO,U,3)_U_$P(ZERO,U)
    11         .S CLASS=$P($G(^PXD(811.9,IEN,100)),U)
    12         .S $P(VALUES(CNT),U,5)=$S(CLASS="N":"NATIONAL",CLASS="L":"LOCAL",1:CLASS)
    13         .S OK=0,NUM=0 F  S NUM=$O(TMPLIST(NUM)) Q:NUM<1  D  Q:OK
    14         ..I IEN=$P(TMPLIST(NUM),U,2) S OK=1
    15         .I OK S $P(VALUES(CNT),U,2)=$P(TMPLIST(NUM),U)
    16         Q
    17         ;
    18 SETREM(OK,VALUES,USER)  ; from ORWTPP
    19         ; save user's reminders
    20         N NUM,ERR
    21         S OK=1
    22         D NDEL^XPAR("USR.`"_USER,"ORQQPX SEARCH ITEMS",.ERR)
    23         S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
    24         .D EN^XPAR(USER_";VA(200,","ORQQPX SEARCH ITEMS",$P(VALUES(NUM),U,1),"`"_$P(VALUES(NUM),U,2),.ERR)
    25         Q
    26         ;
    27 GETOC(VALUES,USER)      ; from ORWTPP
    28         ; get user's order checks
    29         N CNT,IEN,LIST,NUM,VAL,VALOK K LIST,VALUES
    30         S IEN=0 F  S IEN=$O(^ORD(100.8,IEN)) Q:IEN<1  D
    31         .S VAL=$$GET^XPAR("ALL","ORK PROCESSING FLAG",IEN,"I")
    32         .I '$L(VAL) Q
    33         .S VALOK=$$GET^XPAR("ALL","ORK EDITABLE BY USER",IEN,"I")
    34         .S LIST(IEN)=VAL_U_VALOK
    35         S NUM=0,CNT=0 F  S NUM=$O(LIST(NUM)) Q:NUM<1  D
    36         .S CNT=CNT+1
    37         .S VALUES(CNT)=NUM_U_$P($G(^ORD(100.8,NUM,0)),U)_U_$S($P(LIST(NUM),U)="E":"ON",1:"OFF")_U_$S($P(LIST(NUM),U,2)="0":"MANDATORY",1:"")
    38         Q
    39         ;
    40 SAVEOC(OK,VALUES,USER)  ; from ORWTPP
    41         ; save user's order checks
    42         N NUM,ERR
    43         S OK=1
    44         S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
    45         .D EN^XPAR(USER_";VA(200,","ORK PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR)
    46         Q
    47         ;
    48         ;
    49 GETNOT(VALUES,USER)     ; from ORWTPP
    50         ; get user's notifications
    51         N CNT,IEN,NAME,RESULT K VALUES
    52         S CNT=0
    53         S NAME="" F  S NAME=$O(^ORD(100.9,"B",NAME)) Q:NAME=""  D
    54         .S IEN=0  F  S IEN=$O(^ORD(100.9,"B",NAME,IEN)) Q:IEN<1  D
    55         ..S RESULT=$$ONOFF^ORB3USER(IEN,USER,"","") I $L($G(RESULT)) D
    56         ...S CNT=CNT+1
    57         ...S VALUES(CNT)=IEN_U_NAME_U_$P(RESULT,U)_U_$S($$UP^XLFSTR($P(RESULT,U,3))["MANDATORY":"MANDATORY",1:"")
    58         Q
    59         ;
    60 SAVENOT(OK,VALUES,USER) ; from ORWTPP
    61         ; save user's notifications
    62         N ERR,NUM
    63         S OK=1
    64         S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
    65         .D EN^XPAR(USER_";VA(200,","ORB PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR)
    66         Q
    67         ;
    68 CLEARNOT(OK,USER)       ; from ORWTPP
    69         ; clear user's notifications
    70         D RECIPURG^XQALBUTL(USER)
    71         S OK=1
    72         Q
    73         ;
    74 GETNOTO(INFO,USER)      ; from ORWTPP
    75         ; get user's other info for notifications
    76         I $$GET^XPAR("USR.`"_USER,"ORB FLAGGED ORDERS BULLETIN",1,"Q")="Y" S $P(INFO,U,2)=1
    77         I $$GET^XPAR("ALL^USR.`"_USER,"ORB ERASE ALL",1,"Q") S $P(INFO,U,3)=1
    78         Q
    79         ;
    80 GETSURR(INFO,USER)      ; from ORWTPP
    81         ; get user's surrogate info
    82         N SURR
    83         D SUROLIST^XQALSURO(USER,.SURR)
    84         S INFO=$G(SURR(1))
    85         Q
    86         ;
    87 SAVESURR(OK,INFO,USER)  ; from ORWTPP
    88         ; save user's surrogate info
    89         N START,STOP,SURR,RET
    90         S OK=1
    91         S SURR=$P(INFO,U,1)
    92         S START=$P(INFO,U,2)
    93         S STOP=$P(INFO,U,3)
    94         S RET=$$SAVESURR^ORWTPUA(USER,SURR,START,STOP)
    95         I 'RET S OK="0^"_RET
    96         Q
    97         ;
    98 SAVENOTO(OK,INFO,USER)  ; from ORWTPP
    99         ; save user's notification settings
    100         N ERR,FLAG,VAL
    101         S OK=1
    102         S FLAG=$P(INFO,U,3)
    103         S VAL=$S(FLAG>0:"Y",1:"@")
    104         D EN^XPAR(USER_";VA(200,","ORB FLAGGED ORDERS BULLETIN",1,VAL,.ERR)
    105         Q
    106         ;
    107 OCDESC(TEXT,IEN)        ; from RPC
    108         N CNT,LINE,NUM K TEXT
    109         S IEN=+$G(IEN) I IEN<1 Q
    110         S TEXT(1)=$P($G(^ORD(100.8,IEN,0)),U)
    111         S TEXT(2)=""
    112         S CNT=2
    113         S NUM=0 F  S NUM=$O(^ORD(100.8,IEN,1,NUM)) Q:NUM<1  S LINE=$G(^(NUM,0)) D
    114         .S CNT=CNT+1
    115         .S TEXT(CNT)=LINE
    116         S TEXT(CNT+1)=""
    117         Q
    118         ;
    119 NOTDESC(TEXT,IEN)       ; from RPC
    120         K TEXT
    121         S IEN=+$G(IEN) I IEN<1 Q
    122         S TEXT(1)=$P($G(^ORD(100.9,IEN,0)),U)
    123         S TEXT(2)=""
    124         S TEXT(3)=$P($G(^ORD(100.9,IEN,4)),U)
    125         S TEXT(4)=""
    126         Q
     1ORWTPR ; SLC/STAFF Personal Preference - Reminders ;5/3/01  15:32
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,173,215**;Oct 24, 2000
     3 ;
     4GETREM(VALUES,USER) ; from ORWTPP
     5 ; get user's reminders
     6 N CLASS,CNT,ERR,IEN,NUM,OK,TMPLIST,ZERO K VALUES
     7 D GETLST^XPAR(.TMPLIST,"USR.`"_USER,"ORQQPX SEARCH ITEMS","Q",.ERR)
     8 S CNT=0,IEN=0 F  S IEN=$O(^PXD(811.9,IEN)) Q:IEN<1  S ZERO=$G(^(IEN,0)) I $L($P(ZERO,U,3)),'$P(ZERO,U,6) D
     9 .S CNT=CNT+1
     10 .S VALUES(CNT)=IEN_"^0^"_$P(ZERO,U,3)_U_$P(ZERO,U)
     11 .S CLASS=$P($G(^PXD(811.9,IEN,100)),U)
     12 .S $P(VALUES(CNT),U,5)=$S(CLASS="N":"NATIONAL",CLASS="L":"LOCAL",1:CLASS)
     13 .S OK=0,NUM=0 F  S NUM=$O(TMPLIST(NUM)) Q:NUM<1  D  Q:OK
     14 ..I IEN=$P(TMPLIST(NUM),U,2) S OK=1
     15 .I OK S $P(VALUES(CNT),U,2)=$P(TMPLIST(NUM),U)
     16 Q
     17 ;
     18SETREM(OK,VALUES,USER) ; from ORWTPP
     19 ; save user's reminders
     20 N NUM,ERR
     21 S OK=1
     22 D NDEL^XPAR("USR.`"_USER,"ORQQPX SEARCH ITEMS",.ERR)
     23 S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
     24 .D EN^XPAR(USER_";VA(200,","ORQQPX SEARCH ITEMS",$P(VALUES(NUM),U,1),"`"_$P(VALUES(NUM),U,2),.ERR)
     25 Q
     26 ;
     27GETOC(VALUES,USER) ; from ORWTPP
     28 ; get user's order checks
     29 N CNT,IEN,LIST,NUM,VAL,VALOK K LIST,VALUES
     30 S IEN=0 F  S IEN=$O(^ORD(100.8,IEN)) Q:IEN<1  D
     31 .S VAL=$$GET^XPAR("ALL","ORK PROCESSING FLAG",IEN,"I")
     32 .I '$L(VAL) Q
     33 .S VALOK=$$GET^XPAR("ALL","ORK EDITABLE BY USER",IEN,"I")
     34 .S LIST(IEN)=VAL_U_VALOK
     35 S NUM=0,CNT=0 F  S NUM=$O(LIST(NUM)) Q:NUM<1  D
     36 .S CNT=CNT+1
     37 .S VALUES(CNT)=NUM_U_$P($G(^ORD(100.8,NUM,0)),U)_U_$S($P(LIST(NUM),U)="E":"ON",1:"OFF")_U_$S($P(LIST(NUM),U,2)="0":"MANDATORY",1:"")
     38 Q
     39 ;
     40SAVEOC(OK,VALUES,USER) ; from ORWTPP
     41 ; save user's order checks
     42 N NUM,ERR
     43 S OK=1
     44 S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
     45 .D EN^XPAR(USER_";VA(200,","ORK PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR)
     46 Q
     47 ;
     48 ;
     49GETNOT(VALUES,USER) ; from ORWTPP
     50 ; get user's notifications
     51 N CNT,IEN,NAME,RESULT K VALUES
     52 S CNT=0
     53 S NAME="" F  S NAME=$O(^ORD(100.9,"B",NAME)) Q:NAME=""  D
     54 .S IEN=0  F  S IEN=$O(^ORD(100.9,"B",NAME,IEN)) Q:IEN<1  D
     55 ..S RESULT=$$ONOFF^ORB3USER(IEN,USER,"","") I $L($G(RESULT)) D
     56 ...S CNT=CNT+1
     57 ...S VALUES(CNT)=IEN_U_NAME_U_$P(RESULT,U)_U_$S($$UP^XLFSTR($P(RESULT,U,3))["MANDATORY":"MANDATORY",1:"")
     58 Q
     59 ;
     60SAVENOT(OK,VALUES,USER) ; from ORWTPP
     61 ; save user's notifications
     62 N ERR,NUM
     63 S OK=1
     64 S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
     65 .D EN^XPAR(USER_";VA(200,","ORB PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR)
     66 Q
     67 ;
     68CLEARNOT(OK,USER) ; from ORWTPP
     69 ; clear user's notifications
     70 D RECIPURG^XQALBUTL(USER)
     71 S OK=1
     72 Q
     73 ;
     74GETNOTO(INFO,USER) ; from ORWTPP
     75 ; get user's other info for notifications
     76 I $$GET^XPAR("USR.`"_USER,"ORB FLAGGED ORDERS BULLETIN",1,"Q")="Y" S $P(INFO,U,2)=1
     77 I $$GET^XPAR("ALL^USR.`"_USER,"ORB ERASE ALL",1,"Q") S $P(INFO,U,3)=1
     78 Q
     79 ;
     80GETSURR(INFO,USER) ; from ORWTPP
     81 ; get user's surrogate info
     82 N SURR
     83 D SUROLIST^XQALSURO(USER,.SURR)
     84 S INFO=$G(SURR(1))
     85 Q
     86 ;
     87SAVESURR(OK,INFO,USER) ; from ORWTPP
     88 ; save user's surrogate info
     89 N START,STOP,SURR
     90 S OK=1
     91 S SURR=$P(INFO,U,1)
     92 S START=$P(INFO,U,2)
     93 S STOP=$P(INFO,U,3)
     94 D SAVESURR^ORWTPUA(USER,SURR,START,STOP)
     95 Q
     96 ;
     97SAVENOTO(OK,INFO,USER) ; from ORWTPP
     98 ; save user's notification settings
     99 N ERR,FLAG,VAL
     100 S OK=1
     101 S FLAG=$P(INFO,U,3)
     102 S VAL=$S(FLAG>0:"Y",1:"@")
     103 D EN^XPAR(USER_";VA(200,","ORB FLAGGED ORDERS BULLETIN",1,VAL,.ERR)
     104 Q
     105 ;
     106OCDESC(TEXT,IEN) ; from RPC
     107 N CNT,LINE,NUM K TEXT
     108 S IEN=+$G(IEN) I IEN<1 Q
     109 S TEXT(1)=$P($G(^ORD(100.8,IEN,0)),U)
     110 S TEXT(2)=""
     111 S CNT=2
     112 S NUM=0 F  S NUM=$O(^ORD(100.8,IEN,1,NUM)) Q:NUM<1  S LINE=$G(^(NUM,0)) D
     113 .S CNT=CNT+1
     114 .S TEXT(CNT)=LINE
     115 S TEXT(CNT+1)=""
     116 Q
     117 ;
     118NOTDESC(TEXT,IEN) ; from RPC
     119 K TEXT
     120 S IEN=+$G(IEN) I IEN<1 Q
     121 S TEXT(1)=$P($G(^ORD(100.9,IEN,0)),U)
     122 S TEXT(2)=""
     123 S TEXT(3)=$P($G(^ORD(100.9,IEN,4)),U)
     124 S TEXT(4)=""
     125 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPT.m

    r613 r623  
    1 ORWTPT  ; SLC/STAFF Personal Preference - Teams ;5/4/01  15:55
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243**;Oct 24, 2000;Build 242
    3         ;
    4 GETTEAM(USERS,TEAM)     ; RPC
    5         ; returns members of a team
    6         N CNT,NAME,NUM,USER K USERS
    7         S TEAM=+$G(TEAM),CNT=0
    8         S NUM=0 F  S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1  S USER=+$G(^(NUM,0)) D
    9         .S NAME=$P($G(^VA(200,USER,0)),U)
    10         .I '$L(NAME) Q
    11         .S CNT=CNT+1
    12         .S USERS(CNT)=USER_U_NAME
    13         Q
    14         ;
    15 TEAMS(TEAMS,USER)       ; from ORWTPP
    16         ; returns all teams a user is a member of (exculdes personal lists)
    17         N CNT,NUM,ZERO K TEAMS
    18         S USER=+$G(USER),CNT=0
    19         S NUM=0 F  S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1  D
    20         .S ZERO=$G(^OR(100.21,NUM,0))
    21         .I $P(ZERO,U,2)="P" Q
    22         .S CNT=CNT+1
    23         .S TEAMS(CNT)=NUM_U_ZERO
    24         Q
    25         ;
    26 PLISTS(TEAMS,USER)      ; from ORWTPP
    27         ; returns a user's personal lists
    28         N CNT,NUM,ZERO K TEAMS
    29         S USER=+$G(USER),CNT=0
    30         S NUM=0 F  S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1  D
    31         .S ZERO=$G(^OR(100.21,NUM,0))
    32         .I $P(ZERO,U,2)'="P" Q
    33         .S CNT=CNT+1
    34         .N VIS S VIS=$P($G(^OR(100.21,NUM,11)),U)
    35         .I '$L(VIS) S VIS=1
    36         .S TEAMS(CNT)=NUM_U_ZERO_U_VIS
    37         Q
    38         ;
    39 PLTEAMS(TEAMS,USER)     ; from ORWTPP
    40         ; returns all teams and personal lists for a user
    41         N CNT,NUM,ZERO K TEAMS
    42         S USER=+$G(USER),CNT=0
    43         S NUM=0 F  S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1  D
    44         .S ZERO=$G(^OR(100.21,NUM,0))
    45         .S CNT=CNT+1
    46         .S TEAMS(CNT)=NUM_U_ZERO
    47         Q
    48         ;
    49 ATEAMS(TEAMS)   ; RPC
    50         ; all teams available to subscribe to
    51         N CNT,NAME,NODE,NUM K TEAMS
    52         S CNT=0
    53         S NUM=0 F  S NUM=$O(^OR(100.21,NUM)) Q:NUM<1  S NODE=$G(^(NUM,0)) D
    54         .I $P(NODE,U,6)'="Y" Q
    55         .I $P(NODE,U,2)="P" Q
    56         .S CNT=CNT+1
    57         .S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U)
    58         Q
    59         ;
    60 ADDLIST(OK,VALUE,USER)  ; from ORWTPP
    61         ; adds a user to a team
    62         N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO
    63         S USER=+$G(USER)
    64         S DA=USER,DA(1)=+$G(VALUE),OK=1
    65         I '$D(^OR(100.21,DA(1),0)) Q
    66         S DIC(0)="LM"
    67         S DLAYGO=100.212
    68         S X=$P($G(^VA(200,USER,0)),U)
    69         S DIC="^OR(100.21,"_DA(1)_",1,"
    70         D
    71         .L +^OR(100.21,DA(1)):5 I '$T Q
    72         .D ^DIC
    73         .L -^OR(100.21,DA(1))
    74         I Y=-1 S OK=0
    75         K DA,DIC,DLAYGO
    76         Q
    77         ;
    78 REMLIST(OK,VALUE,USER)  ; from ORWTPP
    79         ; removes a user from a team
    80         N DA,DIK K DA
    81         S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1
    82         I '$D(^OR(100.21,DA(1),0)) Q
    83         S DIK="^OR(100.21,"_DA(1)_",1,"
    84         D
    85         .L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q
    86         .D ^DIK
    87         .L -^OR(100.21,DA(1))
    88         K DA,DIK
    89         Q
    90         ;
    91 GETCOMBO(VALUES,USER)   ; from ORWTPP
    92         ; get user's combo list definition
    93         N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES
    94         S USER=+$G(USER)
    95         I '$D(^OR(100.24,USER,0)) Q
    96         S CNT=0
    97         S NUM=0 F  S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1  S NODE=$G(^(NUM,0)) D
    98         .I '$L(NODE) Q
    99         .S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME=""
    100         .D
    101         ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q
    102         ..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q
    103         ..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q
    104         ..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q
    105         ..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q
    106         ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q
    107         .I '$L(NAME) Q
    108         .S CNT=CNT+1
    109         .S VALUES(CNT)=SOURCE_U_NAME_U_IEN
    110         Q
    111         ;
    112 SETCOMBO(OK,VALUES,USER)        ; from ORWTPP
    113         ; set user's combo list definition
    114         N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES
    115         S USER=+$G(USER),OK=1
    116         I 'USER Q
    117         S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
    118         .S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE=""
    119         .I 'IEN Q
    120         .I SOURCENM="WARD" S SOURCE=";DIC(42,"
    121         .I SOURCENM="PROVIDER" S SOURCE=";VA(200,"
    122         .I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7,"
    123         .I SOURCENM="LIST" S SOURCE=";OR(100.21,"
    124         .I SOURCENM="CLINIC" S SOURCE=";SC("
    125         .I '$L(SOURCE) Q
    126         .S NVALUES(NUM)=IEN_SOURCE
    127         I '$D(^OR(100.24,USER,0)) D  I '$D(^OR(100.24,USER,0)) Q
    128         .L +^OR(100.24,0):5 I '$T S OK=0 Q
    129         .S ^OR(100.24,USER,0)=USER
    130         .S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER
    131         .L -^OR(100.24,0)
    132         S CNT=0,DA=USER,DIK="^OR(100.24,"
    133         L +^OR(100.24,USER,0):5 I '$T Q
    134         K ^OR(100.24,USER,.01)
    135         S NUM=0 F  S NUM=$O(NVALUES(NUM)) Q:NUM<1  D
    136         .S CNT=CNT+1
    137         .S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM)
    138         S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT
    139         D IX1^DIK
    140         L -^OR(100.24,USER,0)
    141         K NVALUES
    142         Q
     1ORWTPT ; SLC/STAFF Personal Preference - Teams ;5/4/01  16:01
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85**;Oct 24, 2000
     3 ;
     4GETTEAM(USERS,TEAM) ; RPC
     5 ; returns members of a team
     6 N CNT,NAME,NUM,USER K USERS
     7 S TEAM=+$G(TEAM),CNT=0
     8 S NUM=0 F  S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1  S USER=+$G(^(NUM,0)) D
     9 .S NAME=$P($G(^VA(200,USER,0)),U)
     10 .I '$L(NAME) Q
     11 .S CNT=CNT+1
     12 .S USERS(CNT)=USER_U_NAME
     13 Q
     14 ;
     15TEAMS(TEAMS,USER) ; from ORWTPP
     16 ; returns all teams a user is a member of (exculdes personal lists)
     17 N CNT,NUM,ZERO K TEAMS
     18 S USER=+$G(USER),CNT=0
     19 S NUM=0 F  S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1  D
     20 .S ZERO=$G(^OR(100.21,NUM,0))
     21 .I $P(ZERO,U,2)="P" Q
     22 .S CNT=CNT+1
     23 .S TEAMS(CNT)=NUM_U_ZERO
     24 Q
     25 ;
     26PLISTS(TEAMS,USER) ; from ORWTPP
     27 ; returns a user's personal lists
     28 N CNT,NUM,ZERO K TEAMS
     29 S USER=+$G(USER),CNT=0
     30 S NUM=0 F  S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1  D
     31 .S ZERO=$G(^OR(100.21,NUM,0))
     32 .I $P(ZERO,U,2)'="P" Q
     33 .S CNT=CNT+1
     34 .S TEAMS(CNT)=NUM_U_ZERO
     35 Q
     36 ;
     37PLTEAMS(TEAMS,USER) ; from ORWTPP
     38 ; returns all teams and personal lists for a user
     39 N CNT,NUM,ZERO K TEAMS
     40 S USER=+$G(USER),CNT=0
     41 S NUM=0 F  S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1  D
     42 .S ZERO=$G(^OR(100.21,NUM,0))
     43 .S CNT=CNT+1
     44 .S TEAMS(CNT)=NUM_U_ZERO
     45 Q
     46 ;
     47ATEAMS(TEAMS) ; RPC
     48 ; all teams available to subscribe to
     49 N CNT,NAME,NODE,NUM K TEAMS
     50 S CNT=0
     51 S NUM=0 F  S NUM=$O(^OR(100.21,NUM)) Q:NUM<1  S NODE=$G(^(NUM,0)) D
     52 .I $P(NODE,U,6)'="Y" Q
     53 .I $P(NODE,U,2)="P" Q
     54 .S CNT=CNT+1
     55 .S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U)
     56 Q
     57 ;
     58ADDLIST(OK,VALUE,USER) ; from ORWTPP
     59 ; adds a user to a team
     60 N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO
     61 S USER=+$G(USER)
     62 S DA=USER,DA(1)=+$G(VALUE),OK=1
     63 I '$D(^OR(100.21,DA(1),0)) Q
     64 S DIC(0)="LM"
     65 S DLAYGO=100.212
     66 S X=$P($G(^VA(200,USER,0)),U)
     67 S DIC="^OR(100.21,"_DA(1)_",1,"
     68 D
     69 .L +^OR(100.21,DA(1)):5 I '$T Q
     70 .D ^DIC
     71 .L -^OR(100.21,DA(1))
     72 I Y=-1 S OK=0
     73 K DA,DIC,DLAYGO
     74 Q
     75 ;
     76REMLIST(OK,VALUE,USER) ; from ORWTPP
     77 ; removes a user from a team
     78 N DA,DIK K DA
     79 S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1
     80 I '$D(^OR(100.21,DA(1),0)) Q
     81 S DIK="^OR(100.21,"_DA(1)_",1,"
     82 D
     83 .L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q
     84 .D ^DIK
     85 .L -^OR(100.21,DA(1))
     86 K DA,DIK
     87 Q
     88 ;
     89GETCOMBO(VALUES,USER) ; from ORWTPP
     90 ; get user's combo list definition
     91 N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES
     92 S USER=+$G(USER)
     93 I '$D(^OR(100.24,USER,0)) Q
     94 S CNT=0
     95 S NUM=0 F  S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1  S NODE=$G(^(NUM,0)) D
     96 .I '$L(NODE) Q
     97 .S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME=""
     98 .D
     99 ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q
     100 ..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q
     101 ..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q
     102 ..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q
     103 ..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q
     104 ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q
     105 .I '$L(NAME) Q
     106 .S CNT=CNT+1
     107 .S VALUES(CNT)=SOURCE_U_NAME_U_IEN
     108 Q
     109 ;
     110SETCOMBO(OK,VALUES,USER) ; from ORWTPP
     111 ; set user's combo list definition
     112 N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES
     113 S USER=+$G(USER),OK=1
     114 I 'USER Q
     115 S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
     116 .S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE=""
     117 .I 'IEN Q
     118 .I SOURCENM="WARD" S SOURCE=";DIC(42,"
     119 .I SOURCENM="PROVIDER" S SOURCE=";VA(200,"
     120 .I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7,"
     121 .I SOURCENM="LIST" S SOURCE=";OR(100.21,"
     122 .I SOURCENM="CLINIC" S SOURCE=";SC("
     123 .I '$L(SOURCE) Q
     124 .S NVALUES(NUM)=IEN_SOURCE
     125 I '$D(^OR(100.24,USER,0)) D  I '$D(^OR(100.24,USER,0)) Q
     126 .L +^OR(100.24,0):5 I '$T S OK=0 Q
     127 .S ^OR(100.24,USER,0)=USER
     128 .S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER
     129 .L -^OR(100.24,0)
     130 S CNT=0,DA=USER,DIK="^OR(100.24,"
     131 L +^OR(100.24,USER,0):5 I '$T Q
     132 K ^OR(100.24,USER,.01)
     133 S NUM=0 F  S NUM=$O(NVALUES(NUM)) Q:NUM<1  D
     134 .S CNT=CNT+1
     135 .S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM)
     136 S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT
     137 D IX1^DIK
     138 L -^OR(100.24,USER,0)
     139 K NVALUES
     140 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPUA.m

    r613 r623  
    1 ORWTPUA ; SLC/STAFF Personal Preference - Utility Alerts ; 4/20/07 10:01am
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243**;Oct 24, 2000;Build 242
    3         ;
    4 START(USER)     ; $$(user) -> user's surrogate start date/time
    5         Q $P($G(^XTV(8992,+$G(USER),0)),U,3)
    6         ;
    7 STOP(USER)      ; $$(user) -> user's surrogate stop date/time
    8         Q $P($G(^XTV(8992,+$G(USER),0)),U,4)
    9         ;
    10 CHKSURR(USER,SURR)      ; $$(user,surrogate) -> 1 if ok else 0^reason for reject
    11         N OK,START
    12         S USER=+$G(USER),SURR=+$G(SURR)
    13         I USER=SURR Q "0^You cannot specify yourself as your own surrogate!"
    14         S START=$$GET1^DIQ(8992,(SURR_","),.02,"I")
    15         I START<.5 Q 1
    16         I START=USER Q "0^You are designated as the surrogate for this user - can't do it!"
    17         S OK=1 F  S START=$$GET1^DIQ(8992,(START_","),.02,"I") Q:START'>0  I START=USER S OK=0 Q
    18         I 'OK Q "0^This forms a circle which leads back to you - can't do it!"
    19         Q 1
    20         ;
    21 GETSURR(USER)   ; $$(user ien) -> surrogate ien
    22         Q $$CURRSURO^XQALSURO(+$G(USER))
    23         ;
    24 SAVESURR(USER,SURR,START,STOP)  ; save user's surrogate info
    25         N RET
    26         D REMVSURO^XQALSURO(USER)
    27         S RET=$$SETSURO1^XQALSURO(USER,SURR,START,STOP)
    28         Q RET
     1ORWTPUA ; SLC/STAFF Personal Preference - Utility Alerts ;5/22/00  09:58
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85**;Oct 24, 2000
     3 ;
     4START(USER) ; $$(user) -> user's surrogate start date/time
     5 Q $P($G(^XTV(8992,+$G(USER),0)),U,3)
     6 ;
     7STOP(USER) ; $$(user) -> user's surrogate stop date/time
     8 Q $P($G(^XTV(8992,+$G(USER),0)),U,4)
     9 ;
     10CHKSURR(USER,SURR) ; $$(user,surrogate) -> 1 if ok else 0^reason for reject
     11 N OK,START
     12 S USER=+$G(USER),SURR=+$G(SURR)
     13 I USER=SURR Q "0^You cannot specify yourself as your own surrogate!"
     14 S START=$$GET1^DIQ(8992,(SURR_","),.02,"I")
     15 I START<.5 Q 1
     16 I START=USER Q "0^You are designated as the surrogate for this user - can't do it!"
     17 S OK=1 F  S START=$$GET1^DIQ(8992,(START_","),.02,"I") Q:START'>0  I START=USER S OK=0 Q
     18 I 'OK Q "0^This forms a circle which leads back to you - can't do it!"
     19 Q 1
     20 ;
     21GETSURR(USER) ; $$(user ien) -> surrogate ien
     22 Q $$CURRSURO^XQALSURO(+$G(USER))
     23 ;
     24SAVESURR(USER,SURR,START,STOP) ; save user's surrogate info
     25 D REMVSURO^XQALSURO(USER)
     26 D SETSURO^XQALSURO(USER,SURR,START,STOP)
     27 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m

    r613 r623  
    1 ORWU    ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am]
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215,243**;Dec 17, 1997;Build 242
    3         ;
    4 DT(Y,X,%DT)     ; Internal Fileman Date/Time
    5         ; change the '00:00' that could be passed so Fileman doesn't reject
    6         I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01"
    7         S %DT=$G(%DT,"TS") D ^%DT K %DT
    8         Q
    9 VALDT(Y,X,%DT)  ; Validate date/time
    10         S:'$D(%DT) %DT="TX" D ^%DT
    11         Q
    12 USERINFO(REC)   ; Relevant info for current user
    13         ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^
    14         ;        COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^
    15         ;        AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^
    16         ;        CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT
    17         N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK
    18         S REC=DUZ_U_$P(^VA(200,DUZ,0),U)
    19         S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
    20         S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ))
    21         S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ))
    22         S $P(REC,U,6)=$$ORDROLE
    23         S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I")
    24         S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
    25         I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME
    26         S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
    27         S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I")
    28         S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7))
    29         S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I")
    30         S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I")
    31         S $P(REC,U,13)=$$KSP^XUPARAM("WHERE")  ; domain
    32         S $P(REC,U,14)=+$G(^VA(200,DUZ,5))     ; service/section
    33         S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I")
    34         S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I")
    35         S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I")
    36         S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I")
    37         S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I")
    38         ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:"
    39         ; IA# 10060 allows read access to ^VA(200 file.
    40         S ORRPL=$G(^VA(200,DUZ,101))           ; RPL node.
    41         S ORRPL1=$P(ORRPL,U)
    42         S $P(REC,U,20)=ORRPL1                  ; ISRPL piece.
    43         S ORRPL2=$P(ORRPL,U,2)
    44         S $P(REC,U,21)=ORRPL2                  ; RPLLIST piece.
    45         ;
    46         ; Additional pieces for CPRS tabs access:
    47         ; IA# 10060 allows read access to ^VA(200.01013 multiple.
    48         S ORDT=DT                              ; Today.
    49         S (CORTABS,RPTTAB)=0
    50         S ORRPL=0
    51         F  S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1  D
    52         .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0))
    53         .I ORTAB="" Q
    54         .S OREFF=$P(ORTAB,U,2)
    55         .S OREXP=$P(ORTAB,U,3)
    56         .S ORTAB=$P(ORTAB,U)
    57         .I ORTAB="" Q
    58         .S ORTAB=$G(^ORD(101.13,ORTAB,0))
    59         .I ORTAB="" Q
    60         .S ORTAB=$P(ORTAB,U)
    61         .I ORTAB="" Q
    62         .S ORTAB=$$UP^XLFSTR(ORTAB)
    63         .S ORDATEOK=1                             ; Default.
    64         .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG.
    65         .I ORDATEOK  D
    66         ..I OREXP="" Q                            ; No exp. date.
    67         ..I (OREXP<ORDT) S ORDATEOK=0             ; Exp. date NG.
    68         ..I (OREXP=ORDT) S ORDATEOK=0             ; Exp. date NG.
    69         .;
    70         .; Set TRUE if OK:
    71         .I ((ORTAB="COR")&(ORDATEOK)) S CORTABS=1
    72         .I ((ORTAB="RPT")&(ORDATEOK)) S RPTTAB=1
    73         ;
    74         ; When done, set all valid tabs for access:
    75         S $P(REC,U,22)=CORTABS                 ; "Core" tabs.
    76         S $P(REC,U,23)=RPTTAB                  ; "Reports" tab.
    77         ;
    78         S $P(REC,U,24)=$P($$SITE^VASITE,U,3)
    79         S $P(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I")
    80         S $P(REC,U,26)=$$PROD^XUPROD
    81         Q
    82         ;
    83 HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key
    84         S VAL=''$D(^XUSEC(KEY,DUZ))
    85         Q
    86 HASOPTN(VAL,OPTION)     ; returns TRUE if the user has access to a menu option
    87         S VAL=+$$ACCESS^XQCHK(DUZ,OPTION)
    88         I VAL'>0 S VAL=0
    89         E  S VAL=1
    90         Q
    91 NPHASKEY(VAL,NP,KEY)    ; returns TRUE if the person has the security key
    92         S VAL=''$D(^XUSEC(KEY,NP))
    93         Q
    94 ORDROLE()       ; returns the role a person takes in ordering
    95         ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
    96         ;I '$G(ORWCLVER) Q 0  ; version of client is to old for ordering
    97         I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5
    98         I $D(^XUSEC("OREMAS",DUZ)) Q 1                           ; clerk
    99         I $D(^XUSEC("ORELSE",DUZ)) Q 2                           ; nurse
    100         I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3  ; doctor
    101         I $D(^XUSEC("PROVIDER",DUZ)) Q 4                         ; student
    102         Q 0
    103 VALIDSIG(ESOK,X)        ; returns TRUE if valid electronic signature
    104         S X=$$DECRYP^XUSRB1(X),ESOK=0                   ; network encrypted
    105         D HASH^XUSHSHP
    106         I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1
    107         Q
    108 TOOLMENU(ORLST) ; returns a list of items for the Tools menu
    109         N ANENT
    110         S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
    111         D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N")
    112         Q
    113 ACTLOC(LOC)     ; Function: returns TRUE if active hospital location
    114         ; IA# 10040.
    115         N D0,X I +$G(^SC(LOC,"OOS")) Q 0                ; screen out OOS entry
    116         S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X  ; chk out of svc wards
    117         S X=$G(^SC(LOC,"I")) I +X=0 Q 1                 ; no inactivate date
    118         I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0  ; chk reactivate date
    119         Q 1                                             ; must still be active
    120         ;
    121 CLINLOC(Y,FROM,DIR)     ; Return a set of clinics from HOSPITAL LOCATION
    122         ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
    123         N I,IEN,CNT S I=0,CNT=44
    124         F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
    125         . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
    126         . . I ($P($G(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN)) Q
    127         . . S I=I+1,Y(I)=IEN_"^"_FROM
    128         Q
    129 INPLOC(Y,FROM,DIR)      ;Return a set of wards from HOSPITAL LOCATION
    130         ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
    131         N I,IEN,CNT S I=0,CNT=44
    132         F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
    133         . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
    134         . . I ($P($G(^SC(IEN,0)),U,3)'="W") Q
    135         . . I '$$ACTLOC(IEN) Q
    136         . . S I=I+1,Y(I)=IEN_"^"_FROM
    137         Q
    138 HOSPLOC(Y,FROM,DIR)     ; Return a set of locations from HOSPITAL LOCATION
    139         ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
    140         N I,IEN,CNT S I=0,CNT=44
    141         F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
    142         . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
    143         . . Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
    144         . . S I=I+1,Y(I)=IEN_"^"_FROM
    145         Q
    146 NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL)      ; Return a set of names from the NEW PERSON file.
    147         ; SLC/PKS: Code moved to ORWU1 on 12/3/2002.
    148         D NP1^ORWU1
    149         Q
    150 GBLREF(VAL,FN)  ; return global reference for file number
    151         S VAL="" Q:'FN
    152         S VAL=$$ROOT^DILFD(+FN)
    153         ; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")"
    154         ; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1)
    155         Q
    156 GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF
    157         ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
    158         N I,IEN,CNT S I=0,CNT=44
    159         F  Q:I'<CNT  S FROM=$O(@REF@(FROM),DIR) Q:FROM=""  D
    160         . S IEN="" F  S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN  D
    161         . . S I=I+1,Y(I)=IEN_"^"_FROM
    162         Q
    163 EXTNAME(VAL,IEN,FN)     ; return external form of pointer
    164         ; IEN=internal number, FN=file number
    165         N REF S REF=$G(^DIC(FN,0,"GL")),VAL=""
    166         I $L(REF),+IEN S VAL=$P($G(@(REF_IEN_",0)")),U)
    167         Q
    168 PARAM(VAL,APARAM)       ; return a parameter value for a user
    169         ; call assumes current user, default entities, single instance
    170         S VAL=$$GET^XPAR("ALL",APARAM,1,"I")
    171         Q
    172 PARAMS(ORLIST,APARAM)   ; return a list of parameter values
    173         ; call assumes current user, default entities, multiple instances
    174         D GETLST^XPAR(.ORLIST,"ALL",APARAM,"Q")
    175         Q
    176 DEVICE(Y,FROM,DIR)      ; Return a subset of entries from the Device file
    177         ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
    178         ; FROM=text to $O from, DIR=$O direction
    179         N I,IEN,CNT,SHOW,X S I=0,CNT=20
    180         I FROM["<" S FROM=$RE($P($RE(FROM),"<  ",2))
    181         F  Q:I'<CNT  S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM=""  D
    182         . S IEN=0 F  S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN  D
    183         .. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP
    184         .. Q:'$D(^%ZIS(1,IEN,0))  S X0=^(0),X1=$G(^(1)),X90=$G(^(90)),X91=$G(^(91)),X95=$G(^(95)),XSTYPE=$G(^("SUBTYPE")),XTIME=$G(^("TIME")),XTYPE=$G(^("TYPE"))
    185         .. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q  ;Printers only
    186         .. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q  ;Device Types
    187         .. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q  ;Queuing allowed
    188         .. S X=+X90 I X,(X'>DT) Q  ;Out of Service
    189         .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'<ORA&(ORPCNT'>ORPX&(ORPCNT'<ORA))!(ORPX<ORA&(ORPCNT'<ORA!(ORPCNT'>ORPX))) Q  ;Prohibited Times
    190         .. S POP=0
    191         .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q
    192         .. Q:POP  ;Security check
    193         .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_"  <"_SHOW_">"
    194         .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3)
    195         Q
    196 URGENCY(Y)      ; -- retrieve set values from dd for discharge summary urgency
    197         N ORDD,I,X
    198         D FIELD^DID(8925,.09,"","POINTER","ORDD")
    199         F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X=""   S Y(I)=$TR(X,":","^")
    200         Q
    201 PATCH(VAL,X)    ; Return 1 if patch X is installed
    202         S VAL=$$PATCH^XPDUTL(X)
    203         Q
    204 VERSION(VAL,X)  ;Return version of package or namespace
    205         S VAL=$$VERSION^XPDUTL(X)
    206         Q
    207 VERSRV(VAL,X,CLVER)     ; Return server version of option name
    208         S ORWCLVER=$G(CLVER)  ; leave in partition for session
    209         N BADVAL,ORLST
    210         D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST")
    211         I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q
    212         S VAL=ORLST("DILIST","ID",1,1)
    213         S VAL=$P(VAL,"version ",2)
    214         S BADVAL=0
    215         I $P(VAL,".",1)="" S BADVAL=1
    216         I $P(VAL,".",2)="" S BADVAL=1
    217         I $P(VAL,".",3)="" S BADVAL=1
    218         I $P(VAL,".",4)="" S BADVAL=1
    219         I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0"
    220         Q
     1ORWU ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am]
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215**;Dec 17, 1997
     3 ;
     4DT(Y,X,%DT) ; Internal Fileman Date/Time
     5 ; change the '00:00' that could be passed so Fileman doesn't reject
     6 I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01"
     7 S %DT=$G(%DT,"TS") D ^%DT K %DT
     8 Q
     9VALDT(Y,X,%DT) ; Validate date/time
     10 S:'$D(%DT) %DT="TX" D ^%DT
     11 Q
     12USERINFO(REC) ; Relevant info for current user
     13 ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^
     14 ;        COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^
     15 ;        AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^
     16 ;        CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT
     17 N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK
     18 S REC=DUZ_U_$P(^VA(200,DUZ,0),U)
     19 S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
     20 S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ))
     21 S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ))
     22 S $P(REC,U,6)=$$ORDROLE
     23 S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I")
     24 S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
     25 I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME
     26 S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
     27 S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I")
     28 S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7))
     29 S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I")
     30 S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I")
     31 S $P(REC,U,13)=$$KSP^XUPARAM("WHERE")  ; domain
     32 S $P(REC,U,14)=+$G(^VA(200,DUZ,5))     ; service/section
     33 S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I")
     34 S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I")
     35 S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I")
     36 S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I")
     37 S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I")
     38 ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:"
     39 ; IA# 10060 allows read access to ^VA(200 file.
     40 S ORRPL=$G(^VA(200,DUZ,101))           ; RPL node.
     41 S ORRPL1=$P(ORRPL,U)
     42 S $P(REC,U,20)=ORRPL1                  ; ISRPL piece.
     43 S ORRPL2=$P(ORRPL,U,2)
     44 S $P(REC,U,21)=ORRPL2                  ; RPLLIST piece.
     45 ;
     46 ; Additional pieces for CPRS tabs access:
     47 ; IA# 10060 allows read access to ^VA(200.01013 multiple.
     48 S ORDT=DT                              ; Today.
     49 S (CORTABS,RPTTAB)=0
     50 S ORRPL=0
     51 F  S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1  D
     52 .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0))
     53 .I ORTAB="" Q
     54 .S OREFF=$P(ORTAB,U,2)
     55 .S OREXP=$P(ORTAB,U,3)
     56 .S ORTAB=$P(ORTAB,U)
     57 .I ORTAB="" Q
     58 .S ORTAB=$G(^ORD(101.13,ORTAB,0))
     59 .I ORTAB="" Q
     60 .S ORTAB=$P(ORTAB,U)
     61 .I ORTAB="" Q
     62 .S ORTAB=$$UP^XLFSTR(ORTAB)
     63 .S ORDATEOK=1                             ; Default.
     64 .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG.
     65 .I ORDATEOK  D
     66 ..I OREXP="" Q                            ; No exp. date.
     67 ..I (OREXP<ORDT) S ORDATEOK=0             ; Exp. date NG.
     68 ..I (OREXP=ORDT) S ORDATEOK=0             ; Exp. date NG.
     69 .;
     70 .; Set TRUE if OK:
     71 .I ((ORTAB="COR")&(ORDATEOK)) S CORTABS=1
     72 .I ((ORTAB="RPT")&(ORDATEOK)) S RPTTAB=1
     73 ;
     74 ; When done, set all valid tabs for access:
     75 S $P(REC,U,22)=CORTABS                 ; "Core" tabs.
     76 S $P(REC,U,23)=RPTTAB                  ; "Reports" tab.
     77 ;
     78 S $P(REC,U,24)=$P($$SITE^VASITE,U,3)
     79 S $P(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I")
     80 S $P(REC,U,26)=$$PROD^XUPROD
     81 Q
     82 ;
     83HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key
     84 S VAL=''$D(^XUSEC(KEY,DUZ))
     85 Q
     86HASOPTN(VAL,OPTION) ; returns TRUE if the user has access to a menu option
     87 S VAL=+$$ACCESS^XQCHK(DUZ,OPTION)
     88 I VAL'>0 S VAL=0
     89 E  S VAL=1
     90 Q
     91NPHASKEY(VAL,NP,KEY)    ; returns TRUE if the person has the security key
     92 S VAL=''$D(^XUSEC(KEY,NP))
     93 Q
     94ORDROLE()    ; returns the role a person takes in ordering
     95 ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
     96 ;I '$G(ORWCLVER) Q 0  ; version of client is to old for ordering
     97 I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5
     98 I $D(^XUSEC("OREMAS",DUZ)) Q 1                           ; clerk
     99 I $D(^XUSEC("ORELSE",DUZ)) Q 2                           ; nurse
     100 I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3  ; doctor
     101 I $D(^XUSEC("PROVIDER",DUZ)) Q 4                         ; student
     102 Q 0
     103VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature
     104 S X=$$DECRYP^XUSRB1(X),ESOK=0                   ; network encrypted
     105 D HASH^XUSHSHP
     106 I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1
     107 Q
     108TOOLMENU(ORLST) ; returns a list of items for the Tools menu
     109 N ANENT
     110 S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
     111 D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N")
     112 Q
     113ACTLOC(LOC) ; Function: returns TRUE if active hospital location
     114 ; IA# 10040.
     115 N D0,X I +$G(^SC(LOC,"OOS")) Q 0                ; screen out OOS entry
     116 S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X  ; chk out of svc wards
     117 S X=$G(^SC(LOC,"I")) I +X=0 Q 1                 ; no inactivate date
     118 I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0  ; chk reactivate date
     119 Q 1                                             ; must still be active
     120 ;
     121CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION
     122 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
     123 N I,IEN,CNT S I=0,CNT=44
     124 F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
     125 . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
     126 . . I ($P($G(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN)) Q
     127 . . S I=I+1,Y(I)=IEN_"^"_FROM
     128 Q
     129INPLOC(Y,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION
     130 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
     131 N I,IEN,CNT S I=0,CNT=44
     132 F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
     133 . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
     134 . . I ($P($G(^SC(IEN,0)),U,3)'="W") Q
     135 . . I '$$ACTLOC(IEN) Q
     136 . . S I=I+1,Y(I)=IEN_"^"_FROM
     137 Q
     138HOSPLOC(Y,FROM,DIR) ; Return a set of locations from HOSPITAL LOCATION
     139 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
     140 N I,IEN,CNT S I=0,CNT=44
     141 F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
     142 . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
     143 . . Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
     144 . . S I=I+1,Y(I)=IEN_"^"_FROM
     145 Q
     146NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL) ; Return a set of names from the NEW PERSON file.
     147 ; SLC/PKS: Code moved to ORWU1 on 12/3/2002.
     148 D NP1^ORWU1
     149 Q
     150GBLREF(VAL,FN) ; return global reference for file number
     151 S VAL="" Q:'FN
     152 S VAL=$$ROOT^DILFD(+FN)
     153 ; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")"
     154 ; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1)
     155 Q
     156GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF
     157 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
     158 N I,IEN,CNT S I=0,CNT=44
     159 F  Q:I'<CNT  S FROM=$O(@REF@(FROM),DIR) Q:FROM=""  D
     160 . S IEN="" F  S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN  D
     161 . . S I=I+1,Y(I)=IEN_"^"_FROM
     162 Q
     163EXTNAME(VAL,IEN,FN) ; return external form of pointer
     164 ; IEN=internal number, FN=file number
     165 N REF S REF=$G(^DIC(FN,0,"GL")),VAL=""
     166 I $L(REF),+IEN S VAL=$P($G(@(REF_IEN_",0)")),U)
     167 Q
     168PARAM(VAL,APARAM)       ; return a parameter value for a user
     169 ; call assumes current user, default entities, single instance
     170 S VAL=$$GET^XPAR("ALL",APARAM,1,"I")
     171 Q
     172DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file
     173 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
     174 ; FROM=text to $O from, DIR=$O direction
     175 N I,IEN,CNT,SHOW,X S I=0,CNT=20
     176 I FROM["<" S FROM=$RE($P($RE(FROM),"<  ",2))
     177 F  Q:I'<CNT  S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM=""  D
     178 . S IEN=0 F  S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN  D
     179 .. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP
     180 .. Q:'$D(^%ZIS(1,IEN,0))  S X0=^(0),X1=$G(^(1)),X90=$G(^(90)),X91=$G(^(91)),X95=$G(^(95)),XSTYPE=$G(^("SUBTYPE")),XTIME=$G(^("TIME")),XTYPE=$G(^("TYPE"))
     181 .. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q  ;Printers only
     182 .. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q  ;Device Types
     183 .. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q  ;Queuing allowed
     184 .. S X=+X90 I X,(X'>DT) Q  ;Out of Service
     185 .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'<ORA&(ORPCNT'>ORPX&(ORPCNT'<ORA))!(ORPX<ORA&(ORPCNT'<ORA!(ORPCNT'>ORPX))) Q  ;Prohibited Times
     186 .. S POP=0
     187 .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q
     188 .. Q:POP  ;Security check
     189 .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_"  <"_SHOW_">"
     190 .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3)
     191 Q
     192URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency
     193 N ORDD,I,X
     194 D FIELD^DID(8925,.09,"","POINTER","ORDD")
     195 F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X=""   S Y(I)=$TR(X,":","^")
     196 Q
     197PATCH(VAL,X) ; Return 1 if patch X is installed
     198 S VAL=$$PATCH^XPDUTL(X)
     199 Q
     200VERSION(VAL,X) ;Return version of package or namespace
     201 S VAL=$$VERSION^XPDUTL(X)
     202 Q
     203VERSRV(VAL,X,CLVER)   ; Return server version of option name
     204 S ORWCLVER=$G(CLVER)  ; leave in partition for session
     205 N BADVAL,ORLST
     206 D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST")
     207 I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q
     208 S VAL=ORLST("DILIST","ID",1,1)
     209 S VAL=$P(VAL,"version ",2)
     210 S BADVAL=0
     211 I $P(VAL,".",1)="" S BADVAL=1
     212 I $P(VAL,".",2)="" S BADVAL=1
     213 I $P(VAL,".",3)="" S BADVAL=1
     214 I $P(VAL,".",4)="" S BADVAL=1
     215 I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0"
     216 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY269.m

    r613 r623  
    1 ORY269  ;WV/CJS - POST INIT FOR OR*3*269 ;1/24/07  23:34
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 29
    3         ; Register Lookup RPCs
    4         N MENU,RPC
    5         S MENU="OR CPRS GUI CHART"
    6         F RPC="ORWPT ENHANCED PATLOOKUP","ORWPT OTHER-RADIOBUTTONS" D INSERT(MENU,RPC)
    7         Q
    8 INSERT(OPTION,RPC)      ; Call FM Updater with each RPC
    9         ; Input  -- OPTION   Option file (#19) Name field (#.01)
    10         ;           RPC      RPC sub-file (#19.05) RPC field (#.01)
    11         ; Output -- None
    12         N FDA,FDAIEN,ERR,DIERR
    13         S FDA(19,"?1,",.01)=OPTION
    14         S FDA(19.05,"?+2,?1,",.01)=RPC
    15         D UPDATE^DIE("E","FDA","FDAIEN","ERR")
    16         Q
     1ORY269 ;WV/CJS - POST INIT FOR OR*3*269 ;1/24/07  23:34
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 28
     3 ; Register Lookup RPCs
     4 N MENU,RPC
     5 S MENU="OR CPRS GUI CHART"
     6 F RPC="ORWPT ENHANCED PATLOOKUP","ORWPT OTHER-RADIOBUTTONS" D INSERT(MENU,RPC)
     7 Q
     8INSERT(OPTION,RPC) ; Call FM Updater with each RPC
     9 ; Input  -- OPTION   Option file (#19) Name field (#.01)
     10 ;           RPC      RPC sub-file (#19.05) RPC field (#.01)
     11 ; Output -- None
     12 N FDA,FDAIEN,ERR,DIERR
     13 S FDA(19,"?1,",.01)=OPTION
     14 S FDA(19.05,"?+2,?1,",.01)=RPC
     15 D UPDATE^DIE("E","FDA","FDAIEN","ERR")
     16 Q

  • WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORYDLG.m

    r613 r623  
    1 ORYDLG  ;SLC/MKB -- Postinit bulletin for order dialogs ;7/28/04  08:18
    2         ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,216,243**;Dec 17, 1997;Build 242
    3         ;
    4 EN(PATCH,ORDLG,USERS)   ; -- look for local copies of ORDLG(NAME) by package,
    5         ;    send list in bulletin to DUZ, POSTMASTER, USERS(DUZ) when done
    6         ;
    7         Q:$O(ORDLG(""))=""  ;none
    8         N ORZ,ORI,X,NM,I,OR0,PKG,DG,ORPKG,ORNATL,DLG,CNT,LR,PS
    9         S ORZ(1)="The following nationally exported order dialogs have been modified by"
    10         S X="this patch:   ",ORI=1,NM="" F  S NM=$O(ORDLG(NM)) Q:NM=""  D
    11         . S ORI=ORI+1,ORZ(ORI)=X_NM,X="              "
    12         . S I=+$O(^ORD(101.41,"AB",NM,0)),OR0=$G(^ORD(101.41,I,0))
    13         . S PKG=+$P(OR0,U,7),DG=+$P(OR0,U,5) S:PKG ORPKG(PKG,DG)=""
    14         . S:$P(NM," ")="LR" LR=1 S:"^PS^PSJ^PSO^PSH^"[(U_$P(NM," ")_U) PS=1
    15         D:$G(LR) LR D:$G(PS) PS ;reset FORMAT codes in changed dialogs
    16         S I=0 F I=1:1 S X=$T(NATL+I) Q:X["ZZZZZ"  S ORNATL($P(X,";",3))=""
    17         S ORI=ORI+1,ORZ(ORI)="Please review and compare the following locally created order dialogs"
    18         S ORI=ORI+1,ORZ(ORI)="that may be copies, for any necessary changes:",CNT=0
    19         S PKG=0 F  S PKG=$O(ORPKG(PKG)) Q:PKG<1  S DLG=0 D
    20         . F  S DLG=+$O(^ORD(101.41,"APKG",PKG,DLG)) Q:DLG<1  D
    21         .. S OR0=$G(^ORD(101.41,DLG,0))  Q:$P(OR0,U,4)'="D"
    22         .. Q:'$D(ORPKG(PKG,+$P(OR0,U,5)))  ;included DispGrp
    23         .. Q:$D(ORNATL($P(OR0,U)))  S CNT=CNT+1
    24         .. S ORI=ORI+1,ORZ(ORI)=$J(DLG,7)_"  "_$P(OR0,U)
    25 EN1     I CNT>0 D  ;local copies found -> send bulletin
    26         . N XMDUZ,XMY,I,XMSUB,XMTEXT,DIFROM
    27         . S XMDUZ="PATCH OR*3*"_$G(PATCH)_" POSTINIT",XMY(.5)=""
    28         . S:$G(DUZ) XMY(DUZ)="" S I=0 F  S I=$O(USERS(I)) Q:I<1  S XMY(I)=""
    29         . S XMSUB=XMDUZ_" COMPLETED",XMTEXT="ORZ(" D ^XMD
    30         . D BMES^XPDUTL("Some national order dialogs have been modified in this patch;")
    31         . D MES^XPDUTL("a bulletin has been sent to the installer listing local copies that")
    32         . D MES^XPDUTL("may need to be reviewed and updated.")
    33         Q
    34         ;
    35 NATL    ;;Nationally exported dialogs
    36         ;;FHW1
    37         ;;FHW2
    38         ;;FHW3
    39         ;;FHW7
    40         ;;FHW8
    41         ;;FHW OP MEAL
    42         ;;FHW SPECIAL MEAL
    43         ;;GMRAOR ALLERGY ENTER/EDIT
    44         ;;GMRCOR CONSULT
    45         ;;GMRCOR REQUEST
    46         ;;GMRVOR
    47         ;;LR OTHER LAB TESTS
    48         ;;OR GWCOND CONDITION
    49         ;;OR GWDIAG DIAGNOSIS
    50         ;;OR GWINST DNR
    51         ;;OR GXACTV OTHER ACTIVITY ORDER
    52         ;;OR GXMISC GENERAL
    53         ;;OR GXMOVE ADMIT PATIENT
    54         ;;OR GXMOVE DISCHARGE
    55         ;;OR GXMOVE EVENT
    56         ;;OR GXMOVE TRANSFER
    57         ;;OR GXMOVE TREATING SPECIALTY
    58         ;;OR GXPARM CALL HO ON
    59         ;;OR GXSKIN DRESSING CHANGE
    60         ;;OR GXTEXT TEXT ONLY ORDER
    61         ;;OR GXTEXT WORD PROCESSING ORDER
    62         ;;ORWD GENERIC ACTIVITY
    63         ;;ORWD GENERIC DIET
    64         ;;ORWD GENERIC NURSING
    65         ;;ORWD GENERIC VITALS
    66         ;;PS MEDS
    67         ;;PSH OERR
    68         ;;PSJ OR PAT OE
    69         ;;PSJI OR PAT FLUID OE
    70         ;;PSO OERR
    71         ;;PSO SUPPLY
    72         ;;RA OERR EXAM
    73         ;;ZZZZZ
    74         ;
    75 PS      ; -- reset FORMAT values in PS dialogs
    76         N DRUG,OI,STR,DLGNM,DLG,PRMT,DA
    77         S DRUG=$$PTR("OR GTX DRUG NAME")
    78         S OI=$$PTR("OR GTX ORDERABLE ITEM"),STR=$$PTR("OR GTX STRENGTH")
    79         F DLGNM="PS MEDS","PSJ OR PAT OE","PSO OERR","PSO SUPPLY","PSH OERR" D
    80         . S DLG=$$PTR(DLGNM)
    81         . F PRMT=OI,STR D
    82         .. S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
    83         .. S:DA $P(^ORD(101.41,DLG,10,DA,2),U,2)=("@"_DRUG)
    84         Q
    85         ; IV dialog
    86         S DLG=$$PTR("PSJI OR PAT FLUID OE"),PRMT=$$PTR("OR GTX INFUSION RATE")
    87         S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
    88         I DA S $P(^ORD(101.41,DLG,10,DA,2),U,2)=("@"_$$PTR("OR GTX SCHEDULE"))
    89         Q
    90         ;
    91 LR      ; -- reset FORMAT value in LR dialog
    92         N DLG,PRMT,DA
    93         S DLG=$$PTR("LR OTHER LAB TESTS"),PRMT=$$PTR("OR GTX SPECIMEN")
    94         S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
    95         I DA S $P(^ORD(101.41,DLG,10,DA,2),U,2)=("="_$$PTR("OR GTX COLLECTION SAMPLE"))
    96         Q
    97         ;
    98 PTR(X)  Q +$O(^ORD(101.41,"B",X,0))
     1ORYDLG ;SLC/MKB -- Postinit bulletin for order dialogs ;7/28/04  08:18
     2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,216**;Dec 17, 1997
     3 ;
     4EN(PATCH,ORDLG,USERS) ; -- look for local copies of ORDLG(NAME) by package,
     5 ;    send list in bulletin to DUZ, POSTMASTER, USERS(DUZ) when done
     6 ;
     7 Q:$O(ORDLG(""))=""  ;none
     8 N ORZ,ORI,X,NM,I,OR0,PKG,DG,ORPKG,ORNATL,DLG,CNT
     9 S ORZ(1)="The following nationally exported order dialogs have been modified by"
     10 S X="this patch:   ",ORI=1,NM="" F  S NM=$O(ORDLG(NM)) Q:NM=""  D
     11 . S ORI=ORI+1,ORZ(ORI)=X_NM,X="              "
     12 . S I=+$O(^ORD(101.41,"AB",NM,0)),OR0=$G(^ORD(101.41,I,0))
     13 . S PKG=+$P(OR0,U,7),DG=+$P(OR0,U,5) S:PKG ORPKG(PKG,DG)=""
     14 S I=0 F I=1:1 S X=$T(NATL+I) Q:X["ZZZZZ"  S ORNATL($P(X,";",3))=""
     15 S ORI=ORI+1,ORZ(ORI)="Please review and compare the following locally created order dialogs"
     16 S ORI=ORI+1,ORZ(ORI)="that may be copies, for any necessary changes:",CNT=0
     17 S PKG=0 F  S PKG=$O(ORPKG(PKG)) Q:PKG<1  S DLG=0 D
     18 . F  S DLG=+$O(^ORD(101.41,"APKG",PKG,DLG)) Q:DLG<1  D
     19 .. S OR0=$G(^ORD(101.41,DLG,0))  Q:$P(OR0,U,4)'="D"
     20 .. Q:'$D(ORPKG(PKG,+$P(OR0,U,5)))  ;included DispGrp
     21 .. Q:$D(ORNATL($P(OR0,U)))  S CNT=CNT+1
     22 .. S ORI=ORI+1,ORZ(ORI)=$J(DLG,7)_"  "_$P(OR0,U)
     23EN1 I CNT>0 D  ;local copies found -> send bulletin
     24 . N XMDUZ,XMY,I,XMSUB,XMTEXT,DIFROM
     25 . S XMDUZ="PATCH OR*3*"_$G(PATCH)_" POSTINIT",XMY(.5)=""
     26 . S:$G(DUZ) XMY(DUZ)="" S I=0 F  S I=$O(USERS(I)) Q:I<1  S XMY(I)=""
     27 . S XMSUB=XMDUZ_" COMPLETED",XMTEXT="ORZ(" D ^XMD
     28 . D BMES^XPDUTL("Some national order dialogs have been modified in this patch;")
     29 . D MES^XPDUTL("a bulletin has been sent to the installer listing local copies that")
     30 . D MES^XPDUTL("may need to be reviewed and updated.")
     31 Q
     32 ;
     33NATL ;;Nationally exported dialogs
     34 ;;FHW1
     35 ;;FHW2
     36 ;;FHW3
     37 ;;FHW7
     38 ;;FHW8
     39 ;;GMRAOR ALLERGY ENTER/EDIT
     40 ;;GMRCOR CONSULT
     41 ;;GMRCOR REQUEST
     42 ;;GMRVOR
     43 ;;LR OTHER LAB TESTS
     44 ;;OR GWCOND CONDITION
     45 ;;OR GWDIAG DIAGNOSIS
     46 ;;OR GWINST DNR
     47 ;;OR GXACTV OTHER ACTIVITY ORDER
     48 ;;OR GXMISC GENERAL
     49 ;;OR GXMOVE ADMIT PATIENT
     50 ;;OR GXMOVE DISCHARGE
     51 ;;OR GXMOVE EVENT
     52 ;;OR GXMOVE TRANSFER
     53 ;;OR GXMOVE TREATING SPECIALTY
     54 ;;OR GXPARM CALL HO ON
     55 ;;OR GXSKIN DRESSING CHANGE
     56 ;;OR GXTEXT TEXT ONLY ORDER
     57 ;;OR GXTEXT WORD PROCESSING ORDER
     58 ;;ORWD GENERIC ACTIVITY
     59 ;;ORWD GENERIC DIET
     60 ;;ORWD GENERIC NURSING
     61 ;;ORWD GENERIC VITALS
     62 ;;PS MEDS
     63 ;;PSJ OR PAT OE
     64 ;;PSJI OR PAT FLUID OE
     65 ;;PSO OERR
     66 ;;PSO SUPPLY
     67 ;;RA OERR EXAM
     68 ;;ZZZZZ
Note: See TracChangeset for help on using the changeset viewer.