PSONEW ;BIR/SAB-new rx order main driver ;05-Jun-2013 15:42;DU
;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,1013,268,225,1015,1017**;DEC 1997;Build 40
;External references L and UL^PSSLOCK supported by DBIA 2789
;External reference to ^VA(200 supported by DBIA 224
;External reference to ^XUSEC supported by DBIA 10076
;External reference to ^ORX1 supported by DBIA 2186
;External reference to ^ORX2 supported by DBIA 867
;External reference to ^TIUEDIT supported by DBIA 2410
;---------------------------------------------------------------
; Modified - IHS/CIA/PLS - 01/02/04 - Line AGAIN+10 and COUN+2
; IHS/MSC/PLS - 09/21/11 - Line DIR+2
; 10/28/11 - Line AGAIN+10
; 06/05/13 - Line DIR+4
OERR ;backdoor new rx for v7
K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET
S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
AGAIN N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN") W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"))=0,PSOFROM="NEW",PSONOEDT=1
K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry
I PSONEW("QFLG") G END
I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END
D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN
I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END
D NOOR I PSONEW("DFLG") D DEL G END
D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct
G:$G(PSORX("FN")) END
D EN^PSON52(.PSONEW) ; Files entry in File 52
D EN^APSPPCC1(PSODFN,PSONEW("IRXN")) ;P1013 - prompt for POV
I $G(APSP("CM"))]"" S $P(^PSRX(PSONEW("IRXN"),9999999),"^",2)=APSP("CM") ; IHS/CIA/PLS - 01/02/04 Set chronic med
I $D(P(99)) S $P(^PSRX(PSONEW("IRXN"),9999999),"^")=+P(99) ; IHS/CIA/PLS - 01/02/04 Set Expiration Date
D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
S VALMBCK="R"
END D EOJ ; Clean up
I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN
D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN)
D RV^PSOORFL
S VALMBCK="R" K PSORX("FN") Q
;----------------------------------------------------------------
DEL ;
W !,$C(7),"RX DELETED",!
I $P($G(PSOPAR),"^",7)=1 D
. S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#",""))
. S PSOX=PSONEW("OLD LAST RX#",PSOY)
. L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
. S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
. D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y
. L -^PS(59,+PSOSITE,PSOY)
. K PSOX,PSOY Q
EOJ ;
I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN
K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT")
D CLEAN^PSOVER1
K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC
S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
.S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
.I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
K RXN,RXN1,^TMP("PSORXN",$J)
I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
K PSONOTE
Q
NOOR ;asks nature of order
N PSONOODF
S PSONOODF=0
I $G(OR0) D G NOORX ;front door
.S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0) I 'PSOI S PSONOOR="" D:$D(^XUSEC("PSORPH",DUZ)) COUN Q ;NoO $P(OR0,"^",7)
.S PSONOODF=1
.D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
.S PSONOOR=Y D:$D(^XUSEC("PSORPH",DUZ)) COUN K DIR,DTOUT,DTOUT,DIRUT
;backdoor order
D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
G:'$D(^XUSEC("PSORPH",DUZ)) NOORX
COUN ;patient counseling
G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
; IHS/CIA/PLS - 01/15/04/ - Skip Counsel prompt if IHS
I $G(DUZ("AG"))="I" S PSOCOU="",PSOCOUU=0 G PRONTE
S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0)
I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q
K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0)
PRONTE K PSONOTE,DIR,DIRUT,DUOUT
I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D K DIR,DIRUT,DUOUT
.S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR
.S PSONOTE=+Y Q ;I 'Y!($D(DIRUT)) Q
NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT
Q
DIR ;ask nature of order
K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q
.;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;IHS/MSC/PLS - 09/21/11 Commented out line
.;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;IHS/MSC/PLS - 09/21/11
.S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIV"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;IHS/MSC/PLS - 06/05/13
.I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q
.S DIRUT=1 K PSONOOR
I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")
K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN")
S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
D ^DIR K DF,PSONODF Q:$D(DIRUT) S PSONOOR=Y
DIRX Q
;
NOORE(PSONEW) ;entry point for renew
D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q
S PSONEW("NOO")=PSONOOR
Q
PSONEW ;BIR/SAB-new rx order main driver ;05-Jun-2013 15:42;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,1013,268,225,1015,1017**;DEC 1997;Build 40
+2 ;External references L and UL^PSSLOCK supported by DBIA 2789
+3 ;External reference to ^VA(200 supported by DBIA 224
+4 ;External reference to ^XUSEC supported by DBIA 10076
+5 ;External reference to ^ORX1 supported by DBIA 2186
+6 ;External reference to ^ORX2 supported by DBIA 867
+7 ;External reference to ^TIUEDIT supported by DBIA 2410
+8 ;---------------------------------------------------------------
+9 ; Modified - IHS/CIA/PLS - 01/02/04 - Line AGAIN+10 and COUN+2
+10 ; IHS/MSC/PLS - 09/21/11 - Line DIR+2
+11 ; 10/28/11 - Line AGAIN+10
+12 ; 06/05/13 - Line DIR+4
OERR ;backdoor new rx for v7
+1 KILL PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET
+2 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
KILL PSOPLCK
SET VALMBCK=""
QUIT
+3 KILL PSOPLCK
SET X=PSODFN_";DPT("
DO LK^ORX2
IF 'Y
SET VALMSG="Another person is entering orders for this patient."
SET VALMBCK=""
DO UL^PSSLOCK(PSODFN)
QUIT
AGAIN NEW VALMCNT
KILL PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN")
WRITE !
DO HLDHDR^PSOLMUTL
SET (PSONEW("QFLG"),PSONEW("DFLG"))=0
SET PSOFROM="NEW"
SET PSONOEDT=1
+1 ; Continue order entry
KILL ORD
DO FULL^VALM1
DO ^PSONEW1
+2 IF PSONEW("QFLG")
GOTO END
+3 IF PSONEW("DFLG")
WRITE !,$CHAR(7),"RX DELETED",!
IF $GET(POERR)
SET POERR("DFLG")=1
SET VALMBCK="Q"
GOTO END
+4 IF $PIECE($GET(PSOPAR),"^",7)=1
DO AUTO^PSONRXN
IF $PIECE($GET(PSOPAR),"^",7)'=1
SET PSOX=PSONEW("RX #")
DO CHECK^PSONRXN
+5 IF PSONEW("DFLG")!PSONEW("QFLG")
DO DEL
IF $GET(POERR)
SET POERR("DFLG")=1
SET VALMBCK="R"
GOTO END
+6 DO NOOR
IF PSONEW("DFLG")
DO DEL
GOTO END
+7 ; Asks if correct
DO ^PSONEW2
IF PSONEW("DFLG")
DO DEL
IF $GET(POERR)
SET POERR("DFLG")=1
SET VALMBCK="R"
GOTO END
+8 IF $GET(PSORX("FN"))
GOTO END
+9 ; Files entry in File 52
DO EN^PSON52(.PSONEW)
+10 ;P1013 - prompt for POV
DO EN^APSPPCC1(PSODFN,PSONEW("IRXN"))
+11 ; IHS/CIA/PLS - 01/02/04 Set chronic med
IF $GET(APSP("CM"))]""
SET $PIECE(^PSRX(PSONEW("IRXN"),9999999),"^",2)=APSP("CM")
+12 ; IHS/CIA/PLS - 01/02/04 Set Expiration Date
IF $DATA(P(99))
SET $PIECE(^PSRX(PSONEW("IRXN"),9999999),"^")=+P(99)
+13 ; Adds newly added rx to PSOSD array
DO NPSOSD^PSOUTIL(.PSONEW)
+14 SET VALMBCK="R"
END ; Clean up
DO EOJ
+1 IF '$GET(PSORX("FN"))
WRITE !
KILL DIR,DIRUT,DUOUT,DTOUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Another New Order for "_PSORX("NAME")
DO ^DIR
KILL DIR,DIRUT,DUOUT,DTOUT
IF Y
KILL PSONEW,PSDRUG,ORD
GOTO AGAIN
+2 DO ^PSOBUILD
DO BLD^PSOORUT1
SET X=PSODFN_";DPT("
DO ULK^ORX2
DO UL^PSSLOCK(PSODFN)
+3 DO RV^PSOORFL
+4 SET VALMBCK="R"
KILL PSORX("FN")
QUIT
+5 ;----------------------------------------------------------------
DEL ;
+1 WRITE !,$CHAR(7),"RX DELETED",!
+2 IF $PIECE($GET(PSOPAR),"^",7)=1
Begin DoDot:1
+3 SET DIE="^PS(59,"
SET DA=PSOSITE
SET PSOY=$ORDER(PSONEW("OLD LAST RX#",""))
+4 SET PSOX=PSONEW("OLD LAST RX#",PSOY)
+5 LOCK +^PS(59,+PSOSITE,PSOY):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+6 SET DR=$SELECT(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
+7 IF PSOX<$PIECE(^PS(59,+PSOSITE,PSOY),"^",3)
DO ^DIE
KILL DIE,X,Y
+8 LOCK -^PS(59,+PSOSITE,PSOY)
+9 KILL PSOX,PSOY
QUIT
End DoDot:1
EOJ ;
+1 ; +Lock set in PSONRXN
IF $DATA(PSONEW("RX #"))
LOCK -^PSRX("B",PSONEW("RX #"))
+2 KILL PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT")
+3 DO CLEAN^PSOVER1
+4 KILL ^TMP("PSORXDC",$JOB),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC
+5 SET RXN=$ORDER(^TMP("PSORXN",$JOB,0))
IF RXN
Begin DoDot:1
+6 SET RXN1=^TMP("PSORXN",$JOB,RXN)
DO EN^PSOHLSN1(RXN,$PIECE(RXN1,"^"),$PIECE(RXN1,"^",2),"",$PIECE(RXN1,"^",3))
+7 IF $PIECE(^PSRX(RXN,"STA"),"^")=5
DO EN^PSOHLSN1(RXN,"SC","ZS","")
End DoDot:1
+8 KILL RXN,RXN1,^TMP("PSORXN",$JOB)
+9 IF $GET(PSONOTE)
DO FULL^VALM1
DO MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
+10 KILL PSONOTE
+11 QUIT
NOOR ;asks nature of order
+1 NEW PSONOODF
+2 SET PSONOODF=0
+3 ;front door
IF $GET(OR0)
Begin DoDot:1
+4 ;NoO $P(OR0,"^",7)
SET PSOI=$SELECT($GET(PSOSIGFL):1,$GET(PSODRUG("OI"))'=$PIECE(OR0,"^",8):1,1:0)
IF 'PSOI
SET PSONOOR=""
IF $DATA(^XUSEC("PSORPH",DUZ))
DO COUN
QUIT
+5 SET PSONOODF=1
+6 DO DIR
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
QUIT
+7 SET PSONOOR=Y
IF $DATA(^XUSEC("PSORPH",DUZ))
DO COUN
KILL DIR,DTOUT,DTOUT,DIRUT
End DoDot:1
GOTO NOORX
+8 ;backdoor order
+9 DO DIR
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
QUIT
+10 SET PSONOOR=Y
KILL DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
+11 IF '$DATA(^XUSEC("PSORPH",DUZ))
GOTO NOORX
COUN ;patient counseling
+1 IF $GET(PSORX("EDIT"))&('$GET(PSOSIGFL))
GOTO NOORX
KILL DIR,DUOUT,DTOUT,DIRUT
+2 ; IHS/CIA/PLS - 01/15/04/ - Skip Counsel prompt if IHS
+3 IF $GET(DUZ("AG"))="I"
SET PSOCOU=""
SET PSOCOUU=0
GOTO PRONTE
+4 SET DIR("B")="NO"
SET DIR(0)="52,41"
DO ^DIR
SET PSOCOU=$SELECT(Y:Y,1:0)
+5 IF $DATA(DIRUT)!('PSOCOU)
SET PSOCOUU=0
IF '$GET(SPEED)
DO PRONTE
QUIT
+6 IF '$GET(PSOCOU)
KILL PSOCOUU
KILL DIR,DUOUT,DTOUT,DIRUT
IF Y
SET DIR(0)="52,42"
SET DIR("B")="NO"
DO ^DIR
SET PSOCOUU=$SELECT(Y:Y,1:0)
PRONTE KILL PSONOTE,DIR,DIRUT,DUOUT
+1 IF $TEXT(MAIN^TIUEDIT)]""
IF '$GET(SPEED)
Begin DoDot:1
+2 SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you want to enter a Progress Note"
SET DIR("A",1)=""
DO ^DIR
KILL DIR
+3 ;I 'Y!($D(DIRUT)) Q
SET PSONOTE=+Y
QUIT
End DoDot:1
KILL DIR,DIRUT,DUOUT
NOORX KILL X,Y,DIR,DUOUT,DTOUT,DIRUT
+1 QUIT
DIR ;ask nature of order
+1 KILL DIR,DTOUT,DTOUT,DIRUT
IF $TEXT(NA^ORX1)]""
Begin DoDot:1
+2 ;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;IHS/MSC/PLS - 09/21/11 Commented out line
+3 ;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;IHS/MSC/PLS - 09/21/11
+4 ;IHS/MSC/PLS - 06/05/13
SET PSONOOR=$$NA^ORX1($SELECT($GET(PSONOODF)!($GET(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIV"_$SELECT(+$GET(^VA(200,DUZ,"PS")):"E",1:""))
+5 IF +PSONOOR
SET (Y,PSONOOR)=$PIECE(PSONOOR,"^",3)
QUIT
+6 SET DIRUT=1
KILL PSONOOR
End DoDot:1
QUIT
+7 IF $DATA(PSONOOR)
SET DF=PSONOOR
SET PSONODF=$SELECT(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")
+8 KILL DIR,DTOUT,DTOUT,DIRUT
SET DIR("A")="Nature of Order: "
SET DIR("B")=$SELECT($DATA(PSONOOR):PSONODF,1:"WRITTEN")
+9 SET DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$SELECT(+$GET(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
+10 DO ^DIR
KILL DF,PSONODF
IF $DATA(DIRUT)
QUIT
SET PSONOOR=Y
DIRX QUIT
+1 ;
NOORE(PSONEW) ;entry point for renew
+1 DO NOOR
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
QUIT
+2 SET PSONEW("NOO")=PSONOOR
+3 QUIT
