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

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • 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
Note: See TracChangeset for help on using the changeset viewer.