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/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m

    r613 r623  
    1 PSGOEC  ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
    2         ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175,201,134**;16 DEC 97;Build 124
    3         ;
    4         ; Reference to ^PS(55 is supported by DBIA# 2191.
    5         ; Reference to ^PSSLOCK is supported by DBIA 2789.
    6         ;
    7 ENA     ; all orders
    8         D ENCV^PSGSETU Q:$D(XQUIT)  S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
    9         F  W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:%  D ENCAM^PSGOEM
    10         S PSGCF=0 Q:%<0  S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND Q
    11         E  F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 Q
    12         E  G DONE
    13         W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1
    14         W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400
    15         F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND W "." D RS,^PSGAL5
    16         F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 W "." D RS
    17         W " . . . DONE!" G DONE
    18 ENCA    ;
    19         D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F  S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1  F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2  I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q
    20         E  F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2  I $P($G(^PS(53.1,Q2,0)),U,21) Q
    21         I  S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D  G DONE
    22         .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1
    23         S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET
    24         F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD  F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"A" D AC
    25         D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"N" D NC
    26         W " . . . DONE!" K PSGORD G DONE
    27 ENO(PSGP,PSGORD)        ; single order
    28         I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q
    29         S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ)))
    30         S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8))
    31         I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q
    32         I $$PNDRNOK(PSGORD) N PSJDCTYP S PSJDCTYP=$$PNDRNA(PSGORD) D:(PSJDCTYP=1!(PSJDCTYP=2)) PNDRN($G(PSJDCTYP),PSGORD) G DONE
    33         I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
    34         F  W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:%  D ENCOM^PSGOEM
    35         I %<0 S VALMBCK="" Q
    36         G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS"
    37         I  D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!"
    38         G DONE
    39 SOC     ;
    40         I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..."
    41         E  I CF,'($G(PSJDCTYP)=2) S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE
    42         ; prompt for requesting provider
    43         I '($G(PSJDCTYP)=2) I CF,'$$REQPROV D ABORT^PSGOEE G DONE
    44         K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP
    45         I 'PSJCOM D
    46         .I PSGORD["U" D ASET:CF,AC
    47         .I PSGORD'["U" D NSET:CF,NC
    48         I PSJCOM N COMFLG S COMFLG=0 D
    49         . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM))  D
    50         .. N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  S (PSGORD,PSJORD)=O_"P" D NSET,NC
    51         .I PSGORD["U" N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  Q:COMFLG  D
    52         .. Q:OO=PSGORD  I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
    53         I PSJCOM Q:COMFLG  N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D
    54         . I OO["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D
    55         .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA
    56         . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC
    57         Q
    58 D1      N %,DA,DIE,DIU,STP,NSTOP
    59         D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
    60         S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE
    61         I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
    62         D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF  ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
    63         Q
    64 OUT     ;
    65         W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1
    66 DONE    ;
    67         K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP Q
    68 ASET    ;
    69         S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"")
    70         Q
    71 NSET    ;
    72         S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q
    73 AC      ;
    74         I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5
    75         I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
    76         Q:'CF  K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)=""
    77         I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS
    78         S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS
    79         Q
    80 NC      ;
    81         I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
    82         I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
    83         Q:'CF  S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21)
    84         I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
    85         I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK
    86         I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS
    87         Q
    88 T       ;
    89         F  W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:%  D ENCTM^PSGOEM1
    90         S T=$S(%<0:"^",1:$E("T",%=1)) Q
    91 RS      ;
    92         ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
    93         S $P(^(4),U,11,14)="^^^" Q
    94 REQPROV()                ;
    95         I $G(PSJDCTYP)=2 Q 1
    96         K PSJDCPRV,DIC,DUOUT,DTOUT,Y
    97         N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
    98         S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
    99         I PROVIDER>0 D
    100         .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
    101         .K DIC,DR,DA,DIQ
    102         .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D
    103         ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1
    104         ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR
    105         K DIC S DIC=200,DIC(0)="AEMQZ"
    106         S:PROVNAME]"" DIC("B")=PROVNAME
    107         S DIC("A")="Requesting PROVIDER: "
    108         S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC
    109         I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y
    110         Q RESULT
    111         ;
    112 PNDRNA(ORDER)   ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order
    113         ; Perform this action only for pending renewals
    114         I '$G(ORDER)!'($G(ORDER)["P") Q 3
    115         ; Quit if original order is no longer active
    116         N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD  D  I ORIGSTOP<$G(PSGDT) Q 1
    117         .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
    118         N NDP2
    119         S NDP2=^PS(53.1,+ORDER,.2) S DRG=NDP2,DO=$P(DRG,"^",2) S DRG=$$ENPDN^PSGMI($P(DRG,"^"))
    120         S ND2=^PS(53.1,+ORDER,2) S SCH=$P(ND2,"^"),START=$P(ND2,"^",2),START=$$FMTE^XLFDT(START,2)
    121         W !!?5,DRG_" "_DO
    122         W !?5,"This order has a pending status. If this pending order"
    123         W !?5,"is discontinued, the original order may still be active."
    124         S DIR("A")="Select order(s) to discontinue"
    125         S DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken"
    126         S DIR("L",1)="1 - DC BOTH Orders"
    127         S DIR("L",2)="2 - DC Pending Order"
    128         S DIR("L",3)="3 - Cancel - No Action Taken" D ^DIR
    129         ; Reverse order - Y=1 - Pending only  Y=2:BOTH
    130         S Y=$S(Y=1:2,Y=2:1,1:3)
    131         Q Y
    132         ;
    133 PNDRN(PSJDCTYP,ORDER)   ; Perform Discontinue action for Pending order only or both Pending and Renewed
    134         ; Perform this action only for pending renewals
    135         N PSGORD S PSGORD=ORDER
    136         Q:'$G(PSGORD)!'($G(PSGORD)["P")
    137         I PSJDCTYP=1 G SOC
    138         I PSJDCTYP=2 S PSJDCTYP=1 D SOC Q:'$G(PSJDCTYP)  D
    139         .I ($G(PSJNOO)<0) Q
    140         .N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0))
    141         .N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D SOC K PSJDCTYP
    142         Q
    143 PNDRNOK(ORDER)  ; Execute DC Pending Renew if
    144         ;                  1) Renewal order is pending/non-verified, and
    145         ;                  2) Original order is not DC'd or Expired
    146         Q:'$G(PSGORD)!'($G(PSGORD)["P") 0
    147         N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD 0  D  I ORIGSTOP<$G(PSGDT) Q 0
    148         .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
    149         Q:'($P($G(^PS(53.1,+PSGORD,0)),U,24)="R") 0
    150         Q 1
     1PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
     2 ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175**;16 DEC 97;Build 18
     3 ;
     4 ; Reference to ^PS(55 is supported by DBIA# 2191.
     5 ; Reference to ^PSSLOCK is supported by DBIA 2789.
     6 ;
     7ENA ; all orders
     8 D ENCV^PSGSETU Q:$D(XQUIT)  S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
     9 F  W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:%  D ENCAM^PSGOEM
     10 S PSGCF=0 Q:%<0  S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND Q
     11 E  F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 Q
     12 E  G DONE
     13 W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1
     14 W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400
     15 F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND W "." D RS,^PSGAL5
     16 F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 W "." D RS
     17 W " . . . DONE!" G DONE
     18ENCA ;
     19 D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F  S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1  F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2  I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q
     20 E  F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2  I $P($G(^PS(53.1,Q2,0)),U,21) Q
     21 I  S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D  G DONE
     22 .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1
     23 S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET
     24 F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD  F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"A" D AC
     25 D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"N" D NC
     26 W " . . . DONE!" K PSGORD G DONE
     27ENO(PSGP,PSGORD) ; single order
     28 I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q
     29 S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ)))
     30 S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8))
     31 I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q
     32 I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
     33 F  W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:%  D ENCOM^PSGOEM
     34 I %<0 S VALMBCK="" Q
     35 G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS"
     36 I  D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!"
     37 G DONE
     38SOC ;
     39 I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..."
     40 E  I CF S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE
     41 ; prompt for requesting provider
     42 I CF,'$$REQPROV D ABORT^PSGOEE G DONE
     43 K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP
     44 I 'PSJCOM D
     45 .I PSGORD["U" D ASET:CF,AC
     46 .I PSGORD'["U" D NSET:CF,NC
     47 I PSJCOM N COMFLG S COMFLG=0 D
     48 . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM))  D
     49 .. N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  S (PSGORD,PSJORD)=O_"P" D NSET,NC
     50 .I PSGORD["U" N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  Q:COMFLG  D
     51 .. Q:OO=PSGORD  I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
     52 I PSJCOM Q:COMFLG  N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D
     53 . I OO["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D
     54 .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA
     55 . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC
     56 Q
     57D1 N %,DA,DIE,DIU,STP,NSTOP
     58 D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
     59 S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE
     60 I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
     61 D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF  ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
     62 Q
     63OUT ;
     64 W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1
     65DONE ;
     66 K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y Q
     67ASET ;
     68 S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"")
     69 Q
     70NSET ;
     71 S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q
     72AC ;
     73 I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5
     74 I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
     75 Q:'CF  K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)=""
     76 I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS
     77 S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS
     78 Q
     79NC ;
     80 I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
     81 I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
     82 Q:'CF  S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21)
     83 I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
     84 I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK
     85 I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS
     86 Q
     87T ;
     88 F  W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:%  D ENCTM^PSGOEM1
     89 S T=$S(%<0:"^",1:$E("T",%=1)) Q
     90RS ;
     91 ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
     92 S $P(^(4),U,11,14)="^^^" Q
     93 ;
     94REQPROV()          ;
     95 K PSJDCPRV,DIC,DUOUT,DTOUT,Y
     96 N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
     97 S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
     98 I $G(PSJRQPND) S PROVIDER=0
     99 I PROVIDER>0 D
     100 .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
     101 .K DIC,DR,DA,DIQ
     102 .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D
     103 ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1
     104 ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR
     105 K DIC S DIC=200,DIC(0)="AEMQZ"
     106 S:PROVNAME]"" DIC("B")=PROVNAME
     107 S DIC("A")="Requesting PROVIDER: "
     108 S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC
     109 I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y
     110 Q RESULT
Note: See TracChangeset for help on using the changeset viewer.