PSJOCDT ;BIR/MV - PROCESS DUPLICATE THERAPY ORDER CHECKS ;6 Jun 07 / 3:37 PM [9/8/14 1:10pm]
;;5.0;INPATIENT MEDICATIONS;**181,260,288,257,281**;16 DEC 97;Build 113
;
; Reference to EN^PSODRDU2 is supported by DBIA# 2189.
;
DT ;
NEW PSJN1,PSJCLASS,PSJDNCNT,PSJNDV,PSJPROSP,PSJOCDT
S PSJCLASS=""
F PSJN1=0:0 S PSJN1=$O(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1)) Q:'PSJN1 D
.D SETCLASS
.F PSJDNCNT=0:0 S PSJDNCNT=$O(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT)) Q:'PSJDNCNT D
..S PSJNDV=$G(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT))
..D SETOC
I '$D(PSJPROSP) Q
D DSPOC
Q
DTDGCK ;This version of DT is only executed when the user selects hidden action CK (Drug Check)
NEW PSJN1,PSJCLASS,PSJDNCNT,PSJNDV,PSJPROSP,PSJOCDT,PSJXX
S PSJCLASS=""
F PSJXX=1:1:2 D
.F PSJN1=0:0 S PSJN1=$O(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1)) Q:'PSJN1 D
..I PSJXX=1 I $P(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",1),";",3)'="PROSPECTIVE" Q
..I PSJXX=2 I $P(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",1),";",3)'="PROFILE" Q
..D SETCLASS
..F PSJDNCNT=0:0 S PSJDNCNT=$O(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT)) Q:'PSJDNCNT D
...S PSJNDV=$G(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT))
...D SETOC
..D DSPOC K PSJOCDT,PSJPROSP S PSJCLASS=""
Q
DSPOC ;
;PSJDSPON(ON) - Is set after the order is displayed so the same order is not displayed again
NEW PSJTYPE,PSJDNM,PSPON,PSJPONX,PSJX,PSJDSPON,PSJCLINF
I '$G(PSJDUPTF) D PAUSE^PSJLMUT1 W @IOF ;1st time through for dup therapy
;
D HDR
F PSJTYPE=0:0 S PSJTYPE=$O(PSJOCDT(PSJTYPE)) Q:'PSJTYPE D
. S PSJDNM="" F S PSJDNM=$O(PSJOCDT(PSJTYPE,PSJDNM)) Q:PSJDNM="" D
.. S PSJPON="" F S PSJPON=$O(PSJOCDT(PSJTYPE,PSJDNM,PSJPON)) Q:PSJPON="" D
... K PSJCLINF S PSJCLINF="" I $P(PSJPON,";",2)'="",PSJOCDT(PSJTYPE,PSJDNM,PSJPON)'="" S PSJCLINF=PSJOCDT(PSJTYPE,PSJDNM,PSJPON),PSJCLINF(2)=PSJPON,PSJCLINF(3)=PSJDNM
... I ($Y+6)>IOSL D PAUSE^PSJMISC(1,) W @IOF
... S PSJPONX=$P(PSJPON,";",2),PSJDUPTF=1
... I PSJTYPE=10,+PSJPONX D
.... I '$D(PSJDSPON(PSJPONX)) D DSPORD^PSJOC(PSJPONX,,.PSJCLINF)
.... S PSJDSPON(PSJPONX)=""
... I ($Y+8)>IOSL D PAUSE^PSJMISC(1,) W @IOF
... I PSJTYPE>10 S PSJDUPTF=1 D
.... I PSJCLINF D CLNDISP^PSJCLNOC(.PSJCLINF) Q
.... D EN^PSODRDU2(DFN,PSJPON,"PSJPRE")
I ($Y+8)>IOSL D PAUSE^PSJMISC(1,) W @IOF
;Break the display text this way so the info on classes are indented correctly. CCR 6466
S PSJCLASS=" Involved in Therapeutic Duplication(s): "_PSJCLASS
S PSJX=$L(PSJCLASS)\65 I ($Y+PSJX+4)>IOSL D PAUSE^PSJMISC(1,) W @IOF
W !,"Class(es)"
D MYWRITE^PSJMISC(PSJCLASS,3,67)
I ($Y+8)>IOSL D PAUSE^PSJMISC(1,) W @IOF
W !
;D LINE^PSJMISC($S($G(PSJOLDN):PSJLINE,1:"="),81)
D LINE^PSJMISC("=",81)
I '$D(PSJOCDT(10)),$D(PSJOCDT),'$D(PSJDGCK) K PSJPAUSE D PAUSE^PSJLMUT1 W @IOF Q
;I ($Y+8)>IOSL D PAUSE^PSJMISC(1,) W @IOF
I $D(PSJDGCK),$D(^TMP($J,"PSJPRE","OUT","THERAPY")) D PAUSE^PSJMISC(1,) W @IOF Q
I $D(PSJDGCK) Q
D CONT
Q:$G(PSGORQF)
S PSJY=$$SORTLST()
K PSJPAUSE
I PSJY=1 D Q
. W !!
. D:'$D(PSJDGCK) PROCLST(PSJY)
I (PSJY>1),+$$DCPROMPT() D
. W !
. S PSJY=$$LST() W !
. D:'$D(PSJDGCK) PROCLST(PSJY)
Q
HDR ;
NEW PSJHDR,PSJDNM,PSJSTAT SET PSJSTAT=""
;
I $D(^TMP($J,"PSJPRE","OUT","DRUGDRUG")) W @IOF
D LINE^PSJMISC("=",81)
S PSJHDR="This patient is already receiving the following INPATIENT and/or OUTPATIENT order(s) for a drug in the same therapeutic class(es)"
S:$D(PSJDGCK) PSJHDR="This patient is already receiving the following INPATIENT and/or OUTPATIENT order(s) for drugs in the same therapeutic class(es)"
S PSJDNM=$O(PSJPROSP("UD",""))
IF $G(PSJDGCK)'="",PSJDNM]"" S PSJHDR=PSJHDR_" as "_PSJDNM_" (Prospective)"_":" D WRITE^PSJMISC(PSJHDR,1,77) Q
IF $G(PSJDGCK)="",PSJDNM]"" S PSJHDR=PSJHDR_" as "_PSJDNM_":" D WRITE^PSJMISC(PSJHDR,1,77) Q
D WRITE^PSJMISC(PSJHDR_":",1,77)
HDR2 ;
W !,"Drug(s) Ordered:"
S PSJDNM="" F S PSJDNM=$O(PSJPROSP("IV",PSJDNM)) Q:PSJDNM="" D
. W !,?3,PSJDNM
. I ($Y+8)>IOSL D PAUSE^PSJMISC() W @IOF
W !
Q
SETCLASS ;Store all classes to display at the end.
NEW PSJN2,PSJCLS
F PSJN2=0:0 S PSJN2=$O(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,PSJN2)) Q:'PSJN2 D
. S PSJCLS=$G(^TMP($J,"PSJPRE","OUT","THERAPY",PSJN1,PSJN2,"CLASS"))
. S PSJCLASS=PSJCLASS_$S(PSJCLASS="":"",1:", ")_PSJCLS
Q
SETOC ;Set PSJOCDT array to sort by Package(Inpt, Outpt: Active, Remote, Pending, Non-VA
;PSJPROSP(UD/IV,drugname)="" - This is used to display the header
;PSJOCDT(package,drugname,Pharm ord#)=""
NEW PSJPON,PSJPKG,PSJTYPE,PSJDNM,PSJPONX,PSJCLINF,PSJDXOPT
S PSJPON=$P(PSJNDV,U) Q:PSJPON=""
S PSJCLINF="",PSJDXOPT=$S($G(PSJDGCK):"PROSPECTIVE",1:"PROFILE")
I $P(PSJPON,";",3)'="PROSPECTIVE" D
.I $P(PSJPON,";")="R" S PSJDXOPT="PROFILE" ;ccr7030
.S:$D(^TMP($J,"PSJPRE","IN",PSJDXOPT,PSJPON)) PSJCLINF=$P(^TMP($J,"PSJPRE","IN",PSJDXOPT,PSJPON),"^",7)
S PSJPONX=$P(PSJPON,";",2)
S PSJTYPE=$P(PSJPON,";") Q:PSJTYPE=""
S PSJDNM=$P(PSJNDV,U,3) Q:PSJDNM=""
S PSJPKG=$S(PSJTYPE["C":10,PSJTYPE="I":10,PSJTYPE="O":20,PSJTYPE="R":30,PSJTYPE="P":40,PSJTYPE="N":50,1:"")
; Set prospective drug name array to display in the header.
I PSJPKG=10,($P(PSJPON,";",3)="PROSPECTIVE") D Q:'$G(PSJDGCK)
.I PSJPONX["V" S PSJPROSP("IV",PSJDNM)="" Q
.I PSJPONX["P",+$G(PSJLIFNI) S PSJPROSP("IV",PSJDNM)="" Q
.I PSJPONX["P",($P($G(^PS(53.1,+PSJPONX,8)),U)]"") S PSJPROSP("IV",PSJDNM)="" Q
.S PSJPROSP("UD",PSJDNM)=""
S PSJOCDT(PSJPKG,PSJDNM,PSJPON)=PSJCLINF
Q
CONT ;Display the continue prompt.
NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
W !
S DIR(0)="Y",DIR("B")="YES",DIR("A")=$S($D(PSJDGCK):"Do you wish to continue",1:"Do you wish to continue with the current order")
S DIR("?",1)="Enter 'NO' if you wish to not continue with the order,",DIR("?")="or 'YES' to continue with the current order."
D ^DIR
I 'Y!($G(PSJDGCK)) S PSGORQF=1 S VALMBCK="R"
Q
DCPROMPT() ;Prompt if user wants to DC order(s)
NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
W !
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to DISCONTINUE any of the listed INPATIENT orders"
S DIR("?",1)="Enter 'NO' if you don't wish to discontinue any of the order(s),",DIR("?")="or 'YES' to discontinue selected order(s)."
D ^DIR
Q Y
SORTLST() ;Sort orders into a numeric list
NEW DIR,DIRUT,DTOUT,DUOUT,PSJN,PSJPON1,PSJMONV,PSJS,PSJSEV1,PSJX,X,Y,PSJDNM,PSJPONX,PSJDSPON,PSOCLINF
;Sort orders into a numeric list
Q:'$D(PSJOCDT(10)) 0
S PSJN=0,PSJDNM=""
F S PSJDNM=$O(PSJOCDT(10,PSJDNM)) Q:PSJDNM="" S PSJS="" F S PSJS=$O(PSJOCDT(10,PSJDNM,PSJS)) Q:PSJS="" D
. S PSJPONX=$P(PSJS,";",2)
. S PSJCLINF="",PSJCLINF=PSJOCDT(10,PSJDNM,PSJS)
. ;Business Rule(s): don't show orders that have a status of DISCONTINUED in list
. Q:$D(PSJDSPON(PSJPONX))
. S PSJDSPON(PSJPONX)=""
. S:'$$CKDC^PSJOCDT PSJN=PSJN+1,PSJOCDTL(PSJN)=PSJPONX
Q PSJN
LST() ;
;Only present the list if there are more than 1 orders the list
F PSJX=0:0 S PSJX=$O(PSJOCDTL(PSJX)) Q:'PSJX D
. I ($Y+6)>IOSL D PAUSE^PSJMISC(1,) W @IOF
. D DSPORD^PSJOC(PSJOCDTL(PSJX),PSJX_". ")
W !
K DIR S DIR(0)="LO^1:"_$O(PSJOCDTL(""),-1),DIR("A")="Enter a list or range of numbers to discontinue" D ^DIR K DIR
Q Y
PROCLST(PSJY) ;DC the orders selected by user
NEW PSJX,PSJX1,PSJON,PSJCLINF
F PSJX1=1:1:$L(PSJY) S PSJX=$P(PSJY,",",PSJX1) Q:PSJX="" D
. I ($Y+8)>IOSL D PAUSE^PSJMISC() W @IOF
. I '$D(PSJOCDTL(PSJX)) Q
. S PSJON=PSJOCDTL(PSJX),PSJCLINF=0
. I $D(PSJOCDTL(PSJX,"CLN")) S PSJCLINF=$P(PSJOCDTL(PSJX,"CLN"),"^"),PSJCLINF(2)=$P(PSJOCDTL(PSJX,"CLN"),"^",2),PSJCLINF(3)=$P(PSJOCDTL(PSJX,"CLN"),"^",3)
. D DC^PSJOCDC(PSGP,PSJON,.PSJCLINF)
. W !
Q
CKDC() ; rule: don't show orders that have a status of DISCONTINUED in list
N PSJCKPON,PSJCKFLD
S (PSJCKFLD,PSJCKPON)="",PSJCKPON=$S(PSJPONX["U":55.06,PSJPONX["I"!(PSJPONX["V"):55.01,1:53.1)
S PSJCKFLD=$S(PSJPONX["V"!(PSJPONX="I"):"100",1:"28") ;Unit dose and pending/non-verified file statuses are in field 28 in each file
D GETS^DIQ(PSJCKPON,+PSJPONX_","_DFN,PSJCKFLD,"I","DCTMP")
I '$D(DCTMP(PSJCKPON,+PSJPONX_","_DFN_",",PSJCKFLD,"I")) K DCTMP Q 0
I DCTMP(PSJCKPON,+PSJPONX_","_DFN_",",PSJCKFLD,"I")="D" K DCTMP Q 1
K DCTMP Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJOCDT 8305 printed Sep 23, 2025@19:44:10 Page 2
PSJOCDT ;BIR/MV - PROCESS DUPLICATE THERAPY ORDER CHECKS ;6 Jun 07 / 3:37 PM [9/8/14 1:10pm]
+1 ;;5.0;INPATIENT MEDICATIONS;**181,260,288,257,281**;16 DEC 97;Build 113
+2 ;
+3 ; Reference to EN^PSODRDU2 is supported by DBIA# 2189.
+4 ;
DT ;
+1 NEW PSJN1,PSJCLASS,PSJDNCNT,PSJNDV,PSJPROSP,PSJOCDT
+2 SET PSJCLASS=""
+3 FOR PSJN1=0:0
SET PSJN1=$ORDER(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1))
if 'PSJN1
QUIT
Begin DoDot:1
+4 DO SETCLASS
+5 FOR PSJDNCNT=0:0
SET PSJDNCNT=$ORDER(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT))
if 'PSJDNCNT
QUIT
Begin DoDot:2
+6 SET PSJNDV=$GET(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT))
+7 DO SETOC
End DoDot:2
End DoDot:1
+8 IF '$DATA(PSJPROSP)
QUIT
+9 DO DSPOC
+10 QUIT
DTDGCK ;This version of DT is only executed when the user selects hidden action CK (Drug Check)
+1 NEW PSJN1,PSJCLASS,PSJDNCNT,PSJNDV,PSJPROSP,PSJOCDT,PSJXX
+2 SET PSJCLASS=""
+3 FOR PSJXX=1:1:2
Begin DoDot:1
+4 FOR PSJN1=0:0
SET PSJN1=$ORDER(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1))
if 'PSJN1
QUIT
Begin DoDot:2
+5 IF PSJXX=1
IF $PIECE(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",1),";",3)'="PROSPECTIVE"
QUIT
+6 IF PSJXX=2
IF $PIECE(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",1),";",3)'="PROFILE"
QUIT
+7 DO SETCLASS
+8 FOR PSJDNCNT=0:0
SET PSJDNCNT=$ORDER(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT))
if 'PSJDNCNT
QUIT
Begin DoDot:3
+9 SET PSJNDV=$GET(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,"DRUGS",PSJDNCNT))
+10 DO SETOC
End DoDot:3
+11 DO DSPOC
KILL PSJOCDT,PSJPROSP
SET PSJCLASS=""
End DoDot:2
End DoDot:1
+12 QUIT
DSPOC ;
+1 ;PSJDSPON(ON) - Is set after the order is displayed so the same order is not displayed again
+2 NEW PSJTYPE,PSJDNM,PSPON,PSJPONX,PSJX,PSJDSPON,PSJCLINF
+3 ;1st time through for dup therapy
IF '$GET(PSJDUPTF)
DO PAUSE^PSJLMUT1
WRITE @IOF
+4 ;
+5 DO HDR
+6 FOR PSJTYPE=0:0
SET PSJTYPE=$ORDER(PSJOCDT(PSJTYPE))
if 'PSJTYPE
QUIT
Begin DoDot:1
+7 SET PSJDNM=""
FOR
SET PSJDNM=$ORDER(PSJOCDT(PSJTYPE,PSJDNM))
if PSJDNM=""
QUIT
Begin DoDot:2
+8 SET PSJPON=""
FOR
SET PSJPON=$ORDER(PSJOCDT(PSJTYPE,PSJDNM,PSJPON))
if PSJPON=""
QUIT
Begin DoDot:3
+9 KILL PSJCLINF
SET PSJCLINF=""
IF $PIECE(PSJPON,";",2)'=""
IF PSJOCDT(PSJTYPE,PSJDNM,PSJPON)'=""
SET PSJCLINF=PSJOCDT(PSJTYPE,PSJDNM,PSJPON)
SET PSJCLINF(2)=PSJPON
SET PSJCLINF(3)=PSJDNM
+10 IF ($Y+6)>IOSL
DO PAUSE^PSJMISC(1,)
WRITE @IOF
+11 SET PSJPONX=$PIECE(PSJPON,";",2)
SET PSJDUPTF=1
+12 IF PSJTYPE=10
IF +PSJPONX
Begin DoDot:4
+13 IF '$DATA(PSJDSPON(PSJPONX))
DO DSPORD^PSJOC(PSJPONX,,.PSJCLINF)
+14 SET PSJDSPON(PSJPONX)=""
End DoDot:4
+15 IF ($Y+8)>IOSL
DO PAUSE^PSJMISC(1,)
WRITE @IOF
+16 IF PSJTYPE>10
SET PSJDUPTF=1
Begin DoDot:4
+17 IF PSJCLINF
DO CLNDISP^PSJCLNOC(.PSJCLINF)
QUIT
+18 DO EN^PSODRDU2(DFN,PSJPON,"PSJPRE")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF ($Y+8)>IOSL
DO PAUSE^PSJMISC(1,)
WRITE @IOF
+20 ;Break the display text this way so the info on classes are indented correctly. CCR 6466
+21 SET PSJCLASS=" Involved in Therapeutic Duplication(s): "_PSJCLASS
+22 SET PSJX=$LENGTH(PSJCLASS)\65
IF ($Y+PSJX+4)>IOSL
DO PAUSE^PSJMISC(1,)
WRITE @IOF
+23 WRITE !,"Class(es)"
+24 DO MYWRITE^PSJMISC(PSJCLASS,3,67)
+25 IF ($Y+8)>IOSL
DO PAUSE^PSJMISC(1,)
WRITE @IOF
+26 WRITE !
+27 ;D LINE^PSJMISC($S($G(PSJOLDN):PSJLINE,1:"="),81)
+28 DO LINE^PSJMISC("=",81)
+29 IF '$DATA(PSJOCDT(10))
IF $DATA(PSJOCDT)
IF '$DATA(PSJDGCK)
KILL PSJPAUSE
DO PAUSE^PSJLMUT1
WRITE @IOF
QUIT
+30 ;I ($Y+8)>IOSL D PAUSE^PSJMISC(1,) W @IOF
+31 IF $DATA(PSJDGCK)
IF $DATA(^TMP($JOB,"PSJPRE","OUT","THERAPY"))
DO PAUSE^PSJMISC(1,)
WRITE @IOF
QUIT
+32 IF $DATA(PSJDGCK)
QUIT
+33 DO CONT
+34 if $GET(PSGORQF)
QUIT
+35 SET PSJY=$$SORTLST()
+36 KILL PSJPAUSE
+37 IF PSJY=1
Begin DoDot:1
+38 WRITE !!
+39 if '$DATA(PSJDGCK)
DO PROCLST(PSJY)
End DoDot:1
QUIT
+40 IF (PSJY>1)
IF +$$DCPROMPT()
Begin DoDot:1
+41 WRITE !
+42 SET PSJY=$$LST()
WRITE !
+43 if '$DATA(PSJDGCK)
DO PROCLST(PSJY)
End DoDot:1
+44 QUIT
HDR ;
+1 NEW PSJHDR,PSJDNM,PSJSTAT
SET PSJSTAT=""
+2 ;
+3 IF $DATA(^TMP($JOB,"PSJPRE","OUT","DRUGDRUG"))
WRITE @IOF
+4 DO LINE^PSJMISC("=",81)
+5 SET PSJHDR="This patient is already receiving the following INPATIENT and/or OUTPATIENT order(s) for a drug in the same therapeutic class(es)"
+6 if $DATA(PSJDGCK)
SET PSJHDR="This patient is already receiving the following INPATIENT and/or OUTPATIENT order(s) for drugs in the same therapeutic class(es)"
+7 SET PSJDNM=$ORDER(PSJPROSP("UD",""))
+8 IF $GET(PSJDGCK)'=""
IF PSJDNM]""
SET PSJHDR=PSJHDR_" as "_PSJDNM_" (Prospective)"_":"
DO WRITE^PSJMISC(PSJHDR,1,77)
QUIT
+9 IF $GET(PSJDGCK)=""
IF PSJDNM]""
SET PSJHDR=PSJHDR_" as "_PSJDNM_":"
DO WRITE^PSJMISC(PSJHDR,1,77)
QUIT
+10 DO WRITE^PSJMISC(PSJHDR_":",1,77)
HDR2 ;
+1 WRITE !,"Drug(s) Ordered:"
+2 SET PSJDNM=""
FOR
SET PSJDNM=$ORDER(PSJPROSP("IV",PSJDNM))
if PSJDNM=""
QUIT
Begin DoDot:1
+3 WRITE !,?3,PSJDNM
+4 IF ($Y+8)>IOSL
DO PAUSE^PSJMISC()
WRITE @IOF
End DoDot:1
+5 WRITE !
+6 QUIT
SETCLASS ;Store all classes to display at the end.
+1 NEW PSJN2,PSJCLS
+2 FOR PSJN2=0:0
SET PSJN2=$ORDER(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,PSJN2))
if 'PSJN2
QUIT
Begin DoDot:1
+3 SET PSJCLS=$GET(^TMP($JOB,"PSJPRE","OUT","THERAPY",PSJN1,PSJN2,"CLASS"))
+4 SET PSJCLASS=PSJCLASS_$SELECT(PSJCLASS="":"",1:", ")_PSJCLS
End DoDot:1
+5 QUIT
SETOC ;Set PSJOCDT array to sort by Package(Inpt, Outpt: Active, Remote, Pending, Non-VA
+1 ;PSJPROSP(UD/IV,drugname)="" - This is used to display the header
+2 ;PSJOCDT(package,drugname,Pharm ord#)=""
+3 NEW PSJPON,PSJPKG,PSJTYPE,PSJDNM,PSJPONX,PSJCLINF,PSJDXOPT
+4 SET PSJPON=$PIECE(PSJNDV,U)
if PSJPON=""
QUIT
+5 SET PSJCLINF=""
SET PSJDXOPT=$SELECT($GET(PSJDGCK):"PROSPECTIVE",1:"PROFILE")
+6 IF $PIECE(PSJPON,";",3)'="PROSPECTIVE"
Begin DoDot:1
+7 ;ccr7030
IF $PIECE(PSJPON,";")="R"
SET PSJDXOPT="PROFILE"
+8 if $DATA(^TMP($JOB,"PSJPRE","IN",PSJDXOPT,PSJPON))
SET PSJCLINF=$PIECE(^TMP($JOB,"PSJPRE","IN",PSJDXOPT,PSJPON),"^",7)
End DoDot:1
+9 SET PSJPONX=$PIECE(PSJPON,";",2)
+10 SET PSJTYPE=$PIECE(PSJPON,";")
if PSJTYPE=""
QUIT
+11 SET PSJDNM=$PIECE(PSJNDV,U,3)
if PSJDNM=""
QUIT
+12 SET PSJPKG=$SELECT(PSJTYPE["C":10,PSJTYPE="I":10,PSJTYPE="O":20,PSJTYPE="R":30,PSJTYPE="P":40,PSJTYPE="N":50,1:"")
+13 ; Set prospective drug name array to display in the header.
+14 IF PSJPKG=10
IF ($PIECE(PSJPON,";",3)="PROSPECTIVE")
Begin DoDot:1
+15 IF PSJPONX["V"
SET PSJPROSP("IV",PSJDNM)=""
QUIT
+16 IF PSJPONX["P"
IF +$GET(PSJLIFNI)
SET PSJPROSP("IV",PSJDNM)=""
QUIT
+17 IF PSJPONX["P"
IF ($PIECE($GET(^PS(53.1,+PSJPONX,8)),U)]"")
SET PSJPROSP("IV",PSJDNM)=""
QUIT
+18 SET PSJPROSP("UD",PSJDNM)=""
End DoDot:1
if '$GET(PSJDGCK)
QUIT
+19 SET PSJOCDT(PSJPKG,PSJDNM,PSJPON)=PSJCLINF
+20 QUIT
CONT ;Display the continue prompt.
+1 NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")=$SELECT($DATA(PSJDGCK):"Do you wish to continue",1:"Do you wish to continue with the current order")
+4 SET DIR("?",1)="Enter 'NO' if you wish to not continue with the order,"
SET DIR("?")="or 'YES' to continue with the current order."
+5 DO ^DIR
+6 IF 'Y!($GET(PSJDGCK))
SET PSGORQF=1
SET VALMBCK="R"
+7 QUIT
DCPROMPT() ;Prompt if user wants to DC order(s)
+1 NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to DISCONTINUE any of the listed INPATIENT orders"
+4 SET DIR("?",1)="Enter 'NO' if you don't wish to discontinue any of the order(s),"
SET DIR("?")="or 'YES' to discontinue selected order(s)."
+5 DO ^DIR
+6 QUIT Y
SORTLST() ;Sort orders into a numeric list
+1 NEW DIR,DIRUT,DTOUT,DUOUT,PSJN,PSJPON1,PSJMONV,PSJS,PSJSEV1,PSJX,X,Y,PSJDNM,PSJPONX,PSJDSPON,PSOCLINF
+2 ;Sort orders into a numeric list
+3 if '$DATA(PSJOCDT(10))
QUIT 0
+4 SET PSJN=0
SET PSJDNM=""
+5 FOR
SET PSJDNM=$ORDER(PSJOCDT(10,PSJDNM))
if PSJDNM=""
QUIT
SET PSJS=""
FOR
SET PSJS=$ORDER(PSJOCDT(10,PSJDNM,PSJS))
if PSJS=""
QUIT
Begin DoDot:1
+6 SET PSJPONX=$PIECE(PSJS,";",2)
+7 SET PSJCLINF=""
SET PSJCLINF=PSJOCDT(10,PSJDNM,PSJS)
+8 ;Business Rule(s): don't show orders that have a status of DISCONTINUED in list
+9 if $DATA(PSJDSPON(PSJPONX))
QUIT
+10 SET PSJDSPON(PSJPONX)=""
+11 if '$$CKDC^PSJOCDT
SET PSJN=PSJN+1
SET PSJOCDTL(PSJN)=PSJPONX
End DoDot:1
+12 QUIT PSJN
LST() ;
+1 ;Only present the list if there are more than 1 orders the list
+2 FOR PSJX=0:0
SET PSJX=$ORDER(PSJOCDTL(PSJX))
if 'PSJX
QUIT
Begin DoDot:1
+3 IF ($Y+6)>IOSL
DO PAUSE^PSJMISC(1,)
WRITE @IOF
+4 DO DSPORD^PSJOC(PSJOCDTL(PSJX),PSJX_". ")
End DoDot:1
+5 WRITE !
+6 KILL DIR
SET DIR(0)="LO^1:"_$ORDER(PSJOCDTL(""),-1)
SET DIR("A")="Enter a list or range of numbers to discontinue"
DO ^DIR
KILL DIR
+7 QUIT Y
PROCLST(PSJY) ;DC the orders selected by user
+1 NEW PSJX,PSJX1,PSJON,PSJCLINF
+2 FOR PSJX1=1:1:$LENGTH(PSJY)
SET PSJX=$PIECE(PSJY,",",PSJX1)
if PSJX=""
QUIT
Begin DoDot:1
+3 IF ($Y+8)>IOSL
DO PAUSE^PSJMISC()
WRITE @IOF
+4 IF '$DATA(PSJOCDTL(PSJX))
QUIT
+5 SET PSJON=PSJOCDTL(PSJX)
SET PSJCLINF=0
+6 IF $DATA(PSJOCDTL(PSJX,"CLN"))
SET PSJCLINF=$PIECE(PSJOCDTL(PSJX,"CLN"),"^")
SET PSJCLINF(2)=$PIECE(PSJOCDTL(PSJX,"CLN"),"^",2)
SET PSJCLINF(3)=$PIECE(PSJOCDTL(PSJX,"CLN"),"^",3)
+7 DO DC^PSJOCDC(PSGP,PSJON,.PSJCLINF)
+8 WRITE !
End DoDot:1
+9 QUIT
CKDC() ; rule: don't show orders that have a status of DISCONTINUED in list
+1 NEW PSJCKPON,PSJCKFLD
+2 SET (PSJCKFLD,PSJCKPON)=""
SET PSJCKPON=$SELECT(PSJPONX["U":55.06,PSJPONX["I"!(PSJPONX["V"):55.01,1:53.1)
+3 ;Unit dose and pending/non-verified file statuses are in field 28 in each file
SET PSJCKFLD=$SELECT(PSJPONX["V"!(PSJPONX="I"):"100",1:"28")
+4 DO GETS^DIQ(PSJCKPON,+PSJPONX_","_DFN,PSJCKFLD,"I","DCTMP")
+5 IF '$DATA(DCTMP(PSJCKPON,+PSJPONX_","_DFN_",",PSJCKFLD,"I"))
KILL DCTMP
QUIT 0
+6 IF DCTMP(PSJCKPON,+PSJPONX_","_DFN_",",PSJCKFLD,"I")="D"
KILL DCTMP
QUIT 1
+7 KILL DCTMP
QUIT 0
