PSJCLOR3 ;BIR/JCH - GET UNIT DOSE/IV CLINIC ORDERS ; 2/28/12 9:11am
;;5.0;INPATIENT MEDICATIONS;**275**;16 DEC 97;Build 157
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^%DTC is supported by DBIA# 10000.
; Reference to ^%ZOSV is supported by DBIA# 10097.
; Reference to XLFDT is supported by DBIA# 10103.
;
ECHK ;
N TMPCLIN S TMPCLIN=+$G(^PS(55,PSGP,5,+O,8)) Q:'$G(TMPCLIN) Q:($O(PSJCLNAR(""))&'$D(PSJCLNAR(TMPCLIN))) Q:(PSGSS'="P")&($G(TMPCLIN)'=$G(PSJCURCL))
S C="A",ON=+O_"U",START=$G(^PS(55,PSGP,5,+O,2)),STOP=$P(START,U,4),START=$P(START,U,2) S:PSJOS START=-START
Q:(STOP<PSGODT)
Q:(START>ENDDT)!(STOP<BEGDT)
Q:((",D,E,")[(","_$E($P($G(^PS(55,PSGP,5,+O,0)),"^",9))_","))
S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:",D,DE,DA,"'[(","_$P(ND,"^",9)_",")) SET S ND4=$G(^PS(55,PSGP,5,+O,4)) I ST'="O",$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)
E I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))
E I PSJOL="S",(STOP>$P($G(PSJDCEXP),U,2)) S C="DF" G SET
E Q:PSJOL="S" S C="O"
SET ;
N PSJCLNM,PSJORANG,DN
I ON["P" Q:'$G(^PS(53.1,+ON,"DSS")) S PSJCLNM=(^("DSS")) Q:(($G(PSGSS)'="P")&'$D(PSJCLNAR(+PSJCLNM))) Q:((PSGSS'="P")&(+$G(PSJCLNM)'=$G(PSJCURCL))) D Q:PSJCLNM=""!$G(PSJORANG)
.S PSJCLNM=$P($G(^SC(+PSJCLNM,0)),"^") Q:PSJCLNM=""
.N TMPSTRT,TMPSTP S TMPSTRT=$P($G(^PS(53.1,+ON,2)),"^",2),TMPSTP=$P($G(^PS(53.1,+ON,2)),"^",4)
.S PSJORANG=((TMPSTRT>PSJEND)!(TMPSTP<PSJBEG))
I ON["P",($D(PRNTON)!($D(P("PRNTON")))) N PSJOK S PSJOK=$$COMCHK($S($G(P("PRNTON"))]"":P("PRNTON"),$G(PRNTON)]"":PRNTON,1:""),PSJPTYP) Q:'PSJOK
NEW DRUGNAME D DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
S DN=DRUGNAME(1),SUB=$S(PSJOS:START,1:$E(DN,1,40))
I ON["P",$G(P("PRNTON"))]"",$G(PRNTON)=+P("PRNTON") Q
I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
I ON["U" Q:'$G(^PS(55,PSGP,5,+ON,8)) S PSJCLNM=^(8) Q:(PSGSS'="P")&('$D(PSJCLNAR(+PSJCLNM))) S PSJCLNM=$P($G(^SC(+PSJCLNM,0)),"^") Q:PSJCLNM=""
S ^TMP("PSJ",$J,PSJCLNM,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),ON)=DN_"^"_$G(NF),PSJOCNT=PSJOCNT+1 Q
IVSET ;Set IV data in ^TMP("PSJ",$J,.
N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND,PSJCLNM
I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)),PSJCLNM=$P(^PS(55,DFN,"IV",+ON,"DSS"),"^") F X=2,3,4,9,17 S P(X)=$P(Y,U,X)
I ON["V",(P(2)=""),(P(3)="") Q
I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q
I ON'["V",ND S P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4),P(4)=$P($G(^PS(53.1,+ON,8)),U),P("PRNTON")=$P($G(^PS(53.1,+ON,.2)),U,8)
I ON'["V",P("PRNTON")]"" N PSJOK S PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP) Q:'PSJOK
D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4))
I $G(DRG) S DRGT=$S($G(DRG("AD",1))]"":$P($G(DRG("AD",1)),U,2),1:$P($G(DRG("SOL",1)),U,2)),ORTX=DRGT
I $G(ORTX)="",(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
S:$G(ORTX)="" ORTX="NOT FOUND"
IVSET1 ;
S TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3)) I TYP'="O" S TYP=$S(ON["P":"z",1:"C")
S STAT=$S($G(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
I P(17)="P"!(P(17)["D")!(P(17)="E") Q
I PSJOL="S",(STAT="O"),(P(3)>$P($G(PSJDCEXP),U,2)) S STAT="DF"
I ON["P",$G(P("PRNTON"))]"" Q:(PRNTON=+P("PRNTON")) S PRNTON=+P("PRNTON"),ON=+P("PRNTON"),PSJCLNM=$P($G(^PS(53.1,+ON,"DSS")),"^")
Q:'$G(PSJCLNM) Q:(PSGSS'="P")&('$D(PSJCLNAR(+PSJCLNM))) Q:((PSGSS'="P")&($G(PSJCURCL)'=(PSJCLNM))) S PSJCLNM=$P($G(^SC(+PSJCLNM,0)),"^") Q:PSJCLNM=""
S ^TMP("PSJ",$J,PSJCLNM,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="^F",PSJOCNT=PSJOCNT+1
Q
ENU ; update status field to reflect expired orders, if necessary
W !!,"...a few moments, I have some updating to do..."
ENUNM ;
F Q=+PSJPAD:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q!(Q>PSGDT) S UPD=Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $D(^PS(55,PSGP,5,QQ,0)),"DEH"'[$E($P(^(0),"^",9)) D
.; naked ref below refers to line above
.S $P(^(0),"^",9)="E",ORIFN=$P(^(0),"^",21) D EN1^PSJHL2(PSGP,"SC",QQ_"U")
K UPD Q
EN(PSJPTYP) ; enter here to find clinic orders meeting search criteria, store in ^TMP
; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
N PSJX,PSJY,BEGDT,ENDDT,ON,P,PSJORD,PSJIVOF,PSJOCNT,QQ,SD,START,STOP,SUB,UDU,PSIVCLND
S BEGDT=$S($G(PSJBEG):PSJBEG,1:1500101) S ENDDT=$S($G(PSJEND):PSJEND,1:$$FMADD^XLFDT(PSGDT,3650)) S BEGDT=$$FMADD^XLFDT(BEGDT,,,-1),ENDDT=$$FMADD^XLFDT(ENDDT,,,1)
S PSJDCEXP=$$RECDCEXP^PSJP()
S PSJOL=$G(PSJOL) ; Initialize if no 'View Profile' option selected
I PSJOL="L",$D(XRTL) D T0^%ZOSV
K ^TMP("PSJ",$J) D NOW^%DTC S PSGDT=+$E(%,1,12),DT=$$DT^XLFDT,PSJOS=$P(PSJSYSP0,"^",11),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1)
S PSJOCNT=0 I PSJPTYP>1 S PSJORD=0 F S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
.S PSIVCLND=$G(^PS(55,DFN,"IV",PSJORD,"DSS")) Q:'$P(PSIVCLND,"^")!'$P(PSIVCLND,"^",2)
.S PSJX=$G(^PS(55,DFN,"IV",+PSJORD,0)) Q:($P(PSJX,"^",2)>$G(PSJEND))!($P(PSJX,"^",3)<$G(PSJBEG))
.S PSJY=$P(PSJX,U,17)
.I $P(PSJX,U,3)<PSGDT,"AR"[PSJY S $P(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E",PSJY="E",ON=+PSJORD D EXPIR^PSIVOE
.I +PSJSYSU=3,('+$P($G(^PS(55,DFN,"IV",+PSJORD,4)),U,4)),($P($G(^(.2)),U,4)="D") S PSJPRI="D"
.I $S($G(PSJPRI)="D":0,PSJY="P":0,$P(PSJX,U,3)>$P($G(PSJDCEXP),U,2):1,1:("DPE"'[$E(PSJY))) S ON=+PSJORD_"V" D IVSET K PSJPRI,ON
D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,(X1,DT)=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)
D ENUNM
F ST="C","O","OC","P","R" S SD=0 F S SD=$O(^PS(55,DFN,5,"AU",ST,SD)) Q:'SD S O=0 F S O=$O(^PS(55,DFN,5,"AU",ST,SD,O)) Q:'O D ECHK
N PRNTON F SD="I","N" S (PRNTON,O)=0 F S O=$O(^PS(53.1,"AS",SD,DFN,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV
D KILL
Q
NVSET ; Set up orders from 53.1.
N ND S ND=$G(^PS(53.1,O,0)) I 'ND D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
I $P(ND,U,15),$G(PSGP) I PSGP'=$P(ND,U,15) D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
I $P(ND,U,9)["D" D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
.N ND2 S ND2=$G(^PS(53.1,O,.2)) I $P(ND2,U,8) K ^PS(53.1,"ACX",$P(ND2,U,8))
Q:$P(ND,U,9)="E"
S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
S C=$S(((SD="N")&($P($G(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$P($G(^PS(53.1,O,.2)),U,8)]"":"CD",$P($G(^PS(53.1,O,.2)),U,4)="S":"CA",$P($G(^(0)),U,24)="R":"CC",1:"CB")
D SET
Q
KILL ;
K P,STAT,TYP,ORTX,N,JJ,DTOUT,%,C,HDT,I,LINE,ND4,NF,O,OK,ORIFN,PSGODT,PSJOCNT,Q,QQ,SD,ST,START,STOP,SUB,UDU,VAIP,VALMBCK,X1,X2
Q
COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
N OK S OK=0
I PSJCOM=0 S OK=1 Q OK
I PSJCOM="" Q OK
I PSJPTYP="" Q OK
I '$D(^PS(53.1,"ACX",PSJCOM)) Q OK
S OK=1 I PSJPTYP=3 Q OK
N PSJON S PSJON=""
F S PSJON=$O(^PS(53.1,"ACX",PSJCOM,PSJON)) Q:'PSJON D Q:OK=0
.I $P($G(^PS(53.1,PSJON,0)),"^",9)["D" K ^PS(53.1,"ACX",PSJCOM)
.I $P($G(^PS(53.1,PSJON,0)),"^",4)'="U",PSJPTYP=1 S OK=0 Q
.I $P($G(^PS(53.1,PSJON,0)),"^",4)="U",PSJPTYP=2 S OK=0 Q
Q OK
PRMPTOR ; Prompt for order numbers
K DIR N PSJSELOR,PSJOTOT S PSJOTOT=+$G(^TMP("PSJPRO",$J,0))
S PSJSELOR=$P(XQORNOD(0),"=",2)
S DIR(0)="LO^"_$S(+PSJOTOT:"1:"_+PSJOTOT,1:"") S DIR("A")=$S($G(PSJOTOT):"Select Orders",1:"Quit") D ^DIR
I ($G(Y)<1) S VALMBCK="R" Q
S PSJSELOR=$P(Y(0),",",1,$L(Y(0),",")-1)
D PRMPTSD
Q
PRMPTSD ; Prompt for start date/time
N PSJQMSG,PSJNEWSD,TMPSELOR,TMPORDER,PSJABORT,PSJSYSW,PSJSYSW0,PSJCLSEL,PSJASTRK,PSJNWDTE,TMPSTR,TMPSTP,PSJREVFY,PSJMATCH,DFN,PSJTMPXQ,PSJNOLOK
N CHKSEL,CHKSEL2,STAT,TMPO,TMPC,I K DIR
S:$G(XQORNOD) PSJTMPXQ=XQORNOD S PSJNOLOK=0
S PSJSYSW0="",PSJSYSW=0,PSJPWD="",DFN=$G(PSGP),PSJREVFY=0 S:'$D(PSGSS) PSGSS=PSGSSAV
I '$G(PSJPAD) N PSJPAD D IN5^VADPT S PSJPAD=+VAIP(13,1)
S:'$G(PSJSELOR) PSJSELOR=$P(XQORNOD(0),"=",2) I $D(^TMP("PSJCLOR",$J)) K ^TMP("PSJON",$J) M ^TMP("PSJON",$J)=^TMP("PSJCLOR",$J)
D ENCV^PSGSETU S $P(PSJASTRK,"*",52)="*"
S TMPSELOR=PSJSELOR
D ORDCHK^PSJCLOR5 I ($G(PSJABORT)>1) S VALMBCK="R" Q
I ($G(TMPSELOR)'=$G(PSJSELOR)) S (Y,PSJSELOR)=TMPSELOR
I '$TR(PSJSELOR,",") D S VALMBCK="R" Q
.W !," No editable orders have been selected - please re-select",! D CONT^PSJOE0
D FULL^VALM1 F D PRMPTSD2 Q:'$G(PSJQMSG)
I '$G(PSJNEWSD)!'$G(PSJSELOR) K PSJSELOR,VALMHDR S VALMBCK="R" Q
N PSJDTTMP S PSJDTTMP=$P(PSJNEWSD,".") F S PSJDTTMP=$O(^PS(55,PSGP,5,"AUS",PSJDTTMP)) Q:'PSJDTTMP S PSJONTMP=0 F S PSJONTMP=$O(^PS(55,PSGP,5,"AUS",PSJDTTMP,PSJONTMP)) Q:'PSJONTMP D
.S TMPC="" F S TMPC=$O(^TMP("PSJON",$J,TMPC)) Q:'TMPC S TMPO=^(TMPC) I TMPO["P"!(TMPO["U"&(+TMPO=+PSJONTMP)) I ((","_PSJSELOR)[(","_TMPC_",")) S PSJMATCH=-1
.F CHKSEL=1:1:$L(PSJSELOR,",") Q:($G(PSJMATCH)<0)!(CHKSEL="")!'$D(^TMP("PSJON",$J,CHKSEL)) S CHKSEL2=$G(^TMP("PSJON",$J,CHKSEL)) I CHKSEL2=+PSJONTMP_"U" S PSJMATCH=-1
.I ($G(PSJMATCH)<0) S PSJMATCH=0 Q
.S STAT=$P($G(^PS(55,PSGP,5,+PSJONTMP,0)),"^",9) Q:STAT'="A"
.I ($P($G(^PS(55,PSGP,5,+PSJONTMP,2)),"^",2)<PSJNEWSD)&($P($G(^PS(55,PSGP,5,+PSJONTMP,2)),"^",4)>PSJNEWSD) S PSJMATCH=1,PSJMATCH(+PSJONTMP_"U")="" Q
.I $P($P($G(^PS(55,PSGP,5,+PSJONTMP,2)),"^",2),".")=$P(PSJNEWSD,"^") S PSJMATCH=1,PSJMATCH(+PSJONTMP_"U")=""
N PSJDTTMP S PSJDTTMP=$P(PSJNEWSD,".") F S PSJDTTMP=$O(^PS(55,PSGP,"IV","AIS",PSJDTTMP)) Q:'PSJDTTMP S PSJONTMP=0 F S PSJONTMP=$O(^PS(55,PSGP,"IV","AIS",PSJDTTMP,PSJONTMP)) Q:'PSJONTMP D
.S TMPC="" F S TMPC=$O(^TMP("PSJON",$J,TMPC)) Q:'TMPC S TMPO=$G(^(TMPC)) I TMPO["P"!(TMPO["V"&(+TMPO=+PSJONTMP)) I ((","_PSJSELOR)[(","_TMPC_",")) S PSJMATCH=-1
.F CHKSEL=1:1:$L(PSJSELOR,",") Q:($G(PSJMATCH)<0)!(CHKSEL="") S CHKSEL2=$G(^TMP("PSJON",$J,CHKSEL)) I CHKSEL2=+PSJONTMP_"V" S PSJMATCH=-1
.I ($G(PSJMATCH)<0) S PSJMATCH=0 Q
.S STAT=$P($G(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",17) Q:STAT'="A"
.I $P($G(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",2)<PSJNEWSD&($P($G(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",3)>PSJNEWSD) S PSJMATCH=1,PSJMATCH(+PSJONTMP_"V")="" Q
.I $P($P($G(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",2),".")=$P(PSJNEWSD,".") S PSJMATCH=1,PSJMATCH(+PSJONTMP_"V")=""
;
K TMPSTP,TMPSTR N ND0,ND2,NDP1
I $G(PSJNEWSD) F PSJCLSEL=1:1:$L(PSJSELOR) S TMPSELOR=$P(PSJSELOR,",",PSJCLSEL) Q:'TMPSELOR S TMPORDER=$G(^TMP("PSJON",$J,TMPSELOR)) Q:TMPORDER="" D
.S ND0=$S(TMPORDER["U":$G(^PS(55,PSGP,5,+TMPORDER,0)),TMPORDER["P":$G(^PS(53.1,+TMPORDER,0)),TMPORDER["V":$G(^PS(55,PSGP,"IV",+TMPORDER,0)),1:"")
.S ND2=$S(TMPORDER["U":$G(^PS(55,PSGP,5,+TMPORDER,2)),TMPORDER["P":$G(^PS(53.1,+TMPORDER,2)),TMPORDER["V":$G(^PS(55,PSGP,"IV",+TMPORDER,2)),1:"")
.S TMPSTP=$S(TMPORDER["U"!(TMPORDER["P"):$P(ND2,"^",4),TMPORDER["V":$P(ND0,"^",3),1:"") I TMPSTP<PSJNEWSD S TMPSTP($P(TMPSTP,"."))=""
;
I $G(PSJMATCH)!($O(TMPSTP("")))!($D(PSJMATCH)>1) D Q:($G(PSJABORT)=2)
.K DIR N TMPCNT,PSJBLANK,PSJDASH S TMPCNT=1 D FULL^VALM1 K DIR N X,Y S DIR("A")="Do you want to view the profile",DIR("A",TMPCNT)=" ",TMPCNT=$G(TMPCNT)+1
.S $P(PSJBLANK," ",75)="",$P(PSJDASH,"-",75)="-"
.I $O(TMPSTP("")) W !!," * The new start date is after one or more stop date(s). * ",!," The stop date(s) will be automatically changed to reflect the new start date.",! D
..N DIR D CONT^PSJOE0
.I ($D(PSJMATCH)>1) W !!," * This patient has active order(s) on "_$$FMTE^XLFDT($P(PSJNEWSD,"."))_". *" D
..W !,"Active Order(s)"_$E(PSJBLANK,1,30)_"Current Start / Stop Dates",!,PSJDASH
.I $G(PSJMATCH)!($D(PSJMATCH)>1) N TMPONST,TMPOINF,PSIVCNT S TMPONST=0 F PSIVCNT=1:1 S TMPONST=$O(PSJMATCH(TMPONST)) Q:'TMPONST D
..N DSPLN,PSIVLCNT K TMPOINF S TMPOINF=1 D DSPORD^PSJCLOR2(PSGP,TMPONST,.TMPOINF) S DSPLN=0 F PSIVLCNT=1:1 S DSPLN=$O(TMPOINF(DSPLN)) Q:'DSPLN D
...I '(PSIVCNT#8)&(PSIVLCNT=1) W ! N DIR D CONT^PSJOE0,CLEAR^VALM1,FULL^VALM1 W !,"Active Order(s) on "_$$FMTE^XLFDT($P(PSJNEWSD,"."))_" (CONTINUED)",!!,"Active Order(s) (CONTINUED)"_$E(PSJBLANK,1,20)_"Current Start / Stop Dates",!,PSJDASH
...W !,TMPOINF(DSPLN)
.S DIR("A",TMPCNT+1)="" S DIR(0)="Y" D ^DIR S PSJABORT=$S(Y>0:0,(Y="^"):2,1:1)
.I $G(PSJABORT) S VALMBCK="R"
I $G(PSJMATCH)!$O(TMPSTP(""))!($D(PSJMATCH)>1) I '$G(PSJABORT) D ^PSJHVARS N VAIN,VADM,PSJLM D FULL^VALM1,ENOR^PSJCLOR4(PSGP) D RESTORE^PSJHVARS S VALMBCK="R"
D FULL^VALM1 W !
I $G(PSJNEWSD) F PSJCLSEL=1:1:$L(PSJSELOR) S TMPSELOR=$P(PSJSELOR,",",PSJCLSEL) Q:'TMPSELOR S TMPORDER=$G(^TMP("PSJON",$J,TMPSELOR)) Q:TMPORDER="" D
.I PSJCLSEL=1 W !,"Selected Orders:",?45,"Current Start / Stop Dates",!,$G(PSJHLIN)
.D DSPORD^PSJCLOR2(PSGP,TMPORDER) I '(PSJCLSEL#7) N DIR W ! D CONT^PSJOE0,CLEAR^VALM1,FULL^VALM1 W !,"Selected Orders (CONTINUED):",?45,"Current Start / Stop Dates",!,$G(PSJHLIN)
I $G(PSJCLSEL)>1 W !,$G(PSJHLIN)
;
S PSJNWDTE=$P($$FMTE^XLFDT(PSJNEWSD,2),":",1,2),PSJNWDTE=$P(PSJNWDTE,"@")_" "_$P(PSJNWDTE,"@",2)
K DIR,X,Y S DIR(0)="Y",DIR("A",1)=" ",DIR("A",2)=" The Start Date/Time for the selected order"_$S(($L(PSJSELOR,",")-2):"s",1:"")_" will"
S DIR("A",3)=" now be changed to "_PSJNWDTE,DIR("A",4)=" "
S DIR("A")=" ",DIR("A")="Are you sure " D ^DIR I '$G(Y) K PSJNEWSD W " ** NOTHING CHANGED **" H 1
K TMPARRAY I $G(PSJNEWSD) F PSJCLSEL=1:1:$L(PSJSELOR) S TMPSELOR=$P(PSJSELOR,",",PSJCLSEL) Q:'TMPSELOR S TMPORDER=$G(^TMP("PSJON",$J,TMPSELOR)) Q:TMPORDER="" S TMPARRAY($J,TMPSELOR)=TMPORDER
I $D(TMPARRAY),$G(PSJNEWSD) F PSJCLSEL=1:1:$L(PSJSELOR) S TMPSELOR=$P(PSJSELOR,",",PSJCLSEL) Q:'TMPSELOR S TMPORDER=$G(TMPARRAY($J,TMPSELOR)) Q:TMPORDER="" D
.N PSJDASH1,PSJDASH2 S $P(PSJDASH1,"-",70)="-" S PSJDASH2=PSJDASH1 F I=2:2:70 S $E(PSJDASH2,I)=" "
.W !!,PSJDASH1,!,PSJDASH1,!,"Now working on order: " D DSPORD^PSJCLOR2(PSGP,TMPORDER)
.I TMPORDER["U"!(TMPORDER["P")!(TMPORDER["V") D NEWORDER^PSJCLOR2(PSGP,TMPORDER,PSJNEWSD,$S($G(PSJREVFY):PSJREVFY,1:$G(PSGOEAV))) I $G(PSJNOLOK) S PSJNOLOK=0 Q
.I PSJNEWSD>PSJEND S PSJEND=$P(PSJNEWSD,".")_".24",$P(PSJTMPED,"^",2)=PSGP
.D INIT^PSJCLOR2(3) S VALMBCK="R"
K PSJSELOR,VALMHDR,TMPARRAY S VALMBCK="R"
Q
PRMPTSD2 ;
K DIR,X,Y N TMPY S PSJQMSG=0
K %DT S %DT("A")="Enter new Start Date/Time: ",%DT="TAE"
D ^%DT Q:Y<0!($D(DTOUT))
S TMPY=Y I TMPY["^" S PSJQMSG=0 Q
I $E(TMPY)="?" K DIR,X,Y D ENHLP^PSGOEM(55.06,10) S PSJQMSG=1 Q
I TMPY'["." W $C(7),!?5," Time is REQUIRED. Re-enter Start Date. " S PSJQMSG=1 Q
I TMPY<($$FMADD^XLFDT(PSGDT,,,-1)) W $C(7),!?3,"Start Date/Time earlier than NOW is not allowed. Re-enter Start Date. " S PSJQMSG=1 Q
I TMPY>($$FMADD^XLFDT(PSGDT,365)) W $C(7),!?3,"Start Date cannot be more than 365 days from today. Re-enter Start Date." S PSJQMSG=1 Q
S TMPNEWSD=TMPY
Q:$G(PSJQMSG)
S PSJNEWSD=TMPNEWSD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCLOR3 14741 printed Apr 09, 2024@21:06:53 Page 2
PSJCLOR3 ;BIR/JCH - GET UNIT DOSE/IV CLINIC ORDERS ; 2/28/12 9:11am
+1 ;;5.0;INPATIENT MEDICATIONS;**275**;16 DEC 97;Build 157
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^%DTC is supported by DBIA# 10000.
+5 ; Reference to ^%ZOSV is supported by DBIA# 10097.
+6 ; Reference to XLFDT is supported by DBIA# 10103.
+7 ;
ECHK ;
+1 NEW TMPCLIN
SET TMPCLIN=+$GET(^PS(55,PSGP,5,+O,8))
if '$GET(TMPCLIN)
QUIT
if ($ORDER(PSJCLNAR(""))&'$DATA(PSJCLNAR(TMPCLIN)))
QUIT
if (PSGSS'="P")&($GET(TMPCLIN)'=$GET(PSJCURCL))
QUIT
+2 SET C="A"
SET ON=+O_"U"
SET START=$GET(^PS(55,PSGP,5,+O,2))
SET STOP=$PIECE(START,U,4)
SET START=$PIECE(START,U,2)
if PSJOS
SET START=-START
+3 if (STOP<PSGODT)
QUIT
+4 if (START>ENDDT)!(STOP<BEGDT)
QUIT
+5 if ((",D,E,")[(","_$EXTRACT($PIECE($GET(^PS(55,PSGP,5,+O,0)),"^",9))_","))
QUIT
+6 SET ND=$GET(^PS(55,PSGP,5,+O,0))
if $SELECT($PIECE(ND,"^",9)=""
GOTO SET
SET ND4=$GET(^PS(55,PSGP,5,+O,4))
IF ST'="O"
IF $SELECT($PIECE(ND,"^",9)="E":$PIECE(ND4,"^",16),1:0)
+7 IF '$TEST
IF ST="O"
IF $PIECE(ND,"^",9)="E"
IF $SELECT('$PIECE(ND4,"^",UDU):1,SD<PSGODT:0,1:$PIECE(ND4,"^",16))
+8 IF '$TEST
IF PSJOL="S"
IF (STOP>$PIECE($GET(PSJDCEXP),U,2))
SET C="DF"
GOTO SET
+9 IF '$TEST
if PSJOL="S"
QUIT
SET C="O"
SET ;
+1 NEW PSJCLNM,PSJORANG,DN
+2 IF ON["P"
if '$GET(^PS(53.1,+ON,"DSS"))
QUIT
SET PSJCLNM=(^("DSS"))
if (($GET(PSGSS)'="P")&'$DATA(PSJCLNAR(+PSJCLNM)))
QUIT
if ((PSGSS'="P")&(+$GET(PSJCLNM)'=$GET(PSJCURCL)))
QUIT
Begin DoDot:1
+3 SET PSJCLNM=$PIECE($GET(^SC(+PSJCLNM,0)),"^")
if PSJCLNM=""
QUIT
+4 NEW TMPSTRT,TMPSTP
SET TMPSTRT=$PIECE($GET(^PS(53.1,+ON,2)),"^",2)
SET TMPSTP=$PIECE($GET(^PS(53.1,+ON,2)),"^",4)
+5 SET PSJORANG=((TMPSTRT>PSJEND)!(TMPSTP<PSJBEG))
End DoDot:1
if PSJCLNM=""!$GET(PSJORANG)
QUIT
+6 IF ON["P"
IF ($DATA(PRNTON)!($DATA(P("PRNTON"))))
NEW PSJOK
SET PSJOK=$$COMCHK($SELECT($GET(P("PRNTON"))]"":P("PRNTON"),$GET(PRNTON)]"":PRNTON,1:""),PSJPTYP)
if 'PSJOK
QUIT
+7 NEW DRUGNAME
DO DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
+8 SET DN=DRUGNAME(1)
SET SUB=$SELECT(PSJOS:START,1:$EXTRACT(DN,1,40))
+9 IF ON["P"
IF $GET(P("PRNTON"))]""
IF $GET(PRNTON)=+P("PRNTON")
QUIT
+10 IF ON["P"
IF $GET(P("PRNTON"))]""
SET PRNTON=+P("PRNTON")
SET ON=+P("PRNTON")
+11 IF ON["U"
if '$GET(^PS(55,PSGP,5,+ON,8))
QUIT
SET PSJCLNM=^(8)
if (PSGSS'="P")&('$DATA(PSJCLNAR(+PSJCLNM)))
QUIT
SET PSJCLNM=$PIECE($GET(^SC(+PSJCLNM,0)),"^")
if PSJCLNM=""
QUIT
+12 SET ^TMP("PSJ",$JOB,PSJCLNM,C,$SELECT(PSJOS:SUB,1:ST),$SELECT(PSJOS:ST,1:SUB),ON)=DN_"^"_$GET(NF)
SET PSJOCNT=PSJOCNT+1
QUIT
IVSET ;Set IV data in ^TMP("PSJ",$J,.
+1 NEW DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND,PSJCLNM
+2 IF ON["V"
SET ON55=ON
SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
SET PSJCLNM=$PIECE(^PS(55,DFN,"IV",+ON,"DSS"),"^")
FOR X=2,3,4,9,17
SET P(X)=$PIECE(Y,U,X)
+3 IF ON["V"
IF (P(2)="")
IF (P(3)="")
QUIT
+4 IF ON'["V"
SET ND=$GET(^PS(53.1,+ON,0))
IF 'ND
KILL ^PS(53.1,"AS",SD,PSGP,+ON)
QUIT
+5 IF ON'["V"
IF ND
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
SET Y=$GET(^PS(53.1,+ON,2))
SET P(9)=$PIECE(Y,U)
SET P(2)=$PIECE(Y,U,2)
SET P(3)=$PIECE(Y,U,4)
SET P(4)=$PIECE($GET(^PS(53.1,+ON,8)),U)
SET P("PRNTON")=$PIECE($GET(^PS(53.1,+ON,.2)),U,8)
+6 IF ON'["V"
IF P("PRNTON")]""
NEW PSJOK
SET PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP)
if 'PSJOK
QUIT
+7 DO @$SELECT(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA")
DO GTOT^PSIVUTL(P(4))
+8 IF $GET(DRG)
SET DRGT=$SELECT($GET(DRG("AD",1))]"":$PIECE($GET(DRG("AD",1)),U,2),1:$PIECE($GET(DRG("SOL",1)),U,2))
SET ORTX=DRGT
+9 IF $GET(ORTX)=""
IF (ON'["V")
DO DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1)
SET ORTX=NAME(1)
+10 if $GET(ORTX)=""
SET ORTX="NOT FOUND"
IVSET1 ;
+1 SET TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3))
IF TYP'="O"
SET TYP=$SELECT(ON["P":"z",1:"C")
+2 SET STAT=$SELECT($GET(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
+3 IF P(17)="P"!(P(17)["D")!(P(17)="E")
QUIT
+4 IF PSJOL="S"
IF (STAT="O")
IF (P(3)>$PIECE($GET(PSJDCEXP),U,2))
SET STAT="DF"
+5 IF ON["P"
IF $GET(P("PRNTON"))]""
if (PRNTON=+P("PRNTON"))
QUIT
SET PRNTON=+P("PRNTON")
SET ON=+P("PRNTON")
SET PSJCLNM=$PIECE($GET(^PS(53.1,+ON,"DSS")),"^")
+6 if '$GET(PSJCLNM)
QUIT
if (PSGSS'="P")&('$DATA(PSJCLNAR(+PSJCLNM)))
QUIT
if ((PSGSS'="P")&($GET(PSJCURCL)'=(PSJCLNM)))
QUIT
SET PSJCLNM=$PIECE($GET(^SC(+PSJCLNM,0)),"^")
if PSJCLNM=""
QUIT
+7 SET ^TMP("PSJ",$JOB,PSJCLNM,STAT,$SELECT(PSJOS:-P(2),1:TYP),$SELECT(PSJOS:TYP,1:ORTX),ON)="^F"
SET PSJOCNT=PSJOCNT+1
+8 QUIT
ENU ; update status field to reflect expired orders, if necessary
+1 WRITE !!,"...a few moments, I have some updating to do..."
ENUNM ;
+1 FOR Q=+PSJPAD:0
SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
if 'Q!(Q>PSGDT)
QUIT
SET UPD=Q
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
if 'QQ
QUIT
IF $DATA(^PS(55,PSGP,5,QQ,0))
IF "DEH"'[$EXTRACT($PIECE(^(0),"^",9))
Begin DoDot:1
+2 ; naked ref below refers to line above
+3 SET $PIECE(^(0),"^",9)="E"
SET ORIFN=$PIECE(^(0),"^",21)
DO EN1^PSJHL2(PSGP,"SC",QQ_"U")
End DoDot:1
+4 KILL UPD
QUIT
EN(PSJPTYP) ; enter here to find clinic orders meeting search criteria, store in ^TMP
+1 ; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
+2 NEW PSJX,PSJY,BEGDT,ENDDT,ON,P,PSJORD,PSJIVOF,PSJOCNT,QQ,SD,START,STOP,SUB,UDU,PSIVCLND
+3 SET BEGDT=$SELECT($GET(PSJBEG):PSJBEG,1:1500101)
SET ENDDT=$SELECT($GET(PSJEND):PSJEND,1:$$FMADD^XLFDT(PSGDT,3650))
SET BEGDT=$$FMADD^XLFDT(BEGDT,,,-1)
SET ENDDT=$$FMADD^XLFDT(ENDDT,,,1)
+4 SET PSJDCEXP=$$RECDCEXP^PSJP()
+5 ; Initialize if no 'View Profile' option selected
SET PSJOL=$GET(PSJOL)
+6 IF PSJOL="L"
IF $DATA(XRTL)
DO T0^%ZOSV
+7 KILL ^TMP("PSJ",$JOB)
DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET DT=$$DT^XLFDT
SET PSJOS=$PIECE(PSJSYSP0,"^",11)
SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)
+8 SET PSJOCNT=0
IF PSJPTYP>1
SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,DFN,"IV",PSJORD))
if 'PSJORD
QUIT
Begin DoDot:1
+9 SET PSIVCLND=$GET(^PS(55,DFN,"IV",PSJORD,"DSS"))
if '$PIECE(PSIVCLND,"^")!'$PIECE(PSIVCLND,"^",2)
QUIT
+10 SET PSJX=$GET(^PS(55,DFN,"IV",+PSJORD,0))
if ($PIECE(PSJX,"^",2)>$GET(PSJEND))!($PIECE(PSJX,"^",3)<$GET(PSJBEG))
QUIT
+11 SET PSJY=$PIECE(PSJX,U,17)
+12 IF $PIECE(PSJX,U,3)<PSGDT
IF "AR"[PSJY
SET $PIECE(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E"
SET PSJY="E"
SET ON=+PSJORD
DO EXPIR^PSIVOE
+13 IF +PSJSYSU=3
IF ('+$PIECE($GET(^PS(55,DFN,"IV",+PSJORD,4)),U,4))
IF ($PIECE($GET(^(.2)),U,4)="D")
SET PSJPRI="D"
+14 IF $SELECT($GET(PSJPRI)="D":0,PSJY="P":0,$PIECE(PSJX,U,3)>$PIECE($GET(PSJDCEXP),U,2):1,1:("DPE"'[$EXTRACT(PSJY)))
SET ON=+PSJORD_"V"
DO IVSET
KILL PSJPRI,ON
End DoDot:1
+15 DO NOW^%DTC
SET PSJIVOF=PSJOCNT
SET PSGDT=%
SET (X1,DT)=$PIECE(%,".")
SET X2=-2
DO C^%DTC
SET PSGODT=X_(PSGDT#1)
SET HDT=$$ENDTC^PSGMI(PSGDT)
+16 DO ENUNM
+17 FOR ST="C","O","OC","P","R"
SET SD=0
FOR
SET SD=$ORDER(^PS(55,DFN,5,"AU",ST,SD))
if 'SD
QUIT
SET O=0
FOR
SET O=$ORDER(^PS(55,DFN,5,"AU",ST,SD,O))
if 'O
QUIT
DO ECHK
+18 NEW PRNTON
FOR SD="I","N"
SET (PRNTON,O)=0
FOR
SET O=$ORDER(^PS(53.1,"AS",SD,DFN,O))
if 'O
QUIT
SET ON=+O_"P"
SET X=$PIECE($GET(^PS(53.1,+O,0)),U,4)
IF $SELECT(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1)
DO NVSET
+19 IF PSJOL="L"
IF $DATA(XRT0)
SET XRTN="PSJO1"
DO T1^%ZOSV
+20 DO KILL
+21 QUIT
NVSET ; Set up orders from 53.1.
+1 NEW ND
SET ND=$GET(^PS(53.1,O,0))
IF 'ND
Begin DoDot:1
+2 KILL ^PS(53.1,"AS",SD,PSGP,O)
End DoDot:1
QUIT
+3 IF $PIECE(ND,U,15)
IF $GET(PSGP)
IF PSGP'=$PIECE(ND,U,15)
Begin DoDot:1
+4 KILL ^PS(53.1,"AS",SD,PSGP,O)
End DoDot:1
QUIT
+5 IF $PIECE(ND,U,9)["D"
Begin DoDot:1
+6 KILL ^PS(53.1,"AS",SD,PSGP,O)
+7 NEW ND2
SET ND2=$GET(^PS(53.1,O,.2))
IF $PIECE(ND2,U,8)
KILL ^PS(53.1,"ACX",$PIECE(ND2,U,8))
End DoDot:1
QUIT
+8 if $PIECE(ND,U,9)="E"
QUIT
+9 SET ST=$PIECE($GET(^PS(53.1,O,0)),U,7)
SET START=-$PIECE($GET(^(2)),U,2)
SET P("PRNTON")=$PIECE($GET(^PS(53.1,O,.2)),"^",8)
if ST=""
SET ST="z"
+10 SET C=$SELECT(((SD="N")&($PIECE($GET(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$PIECE($GET(^PS(53.1,O,.2)),U,8)]"":"CD",$PIECE($GET(^PS(53.1,O,.2)),U,4)="S":"CA",$PIECE($GET(^(0)),U,24)="R":"CC",1:"CB")
+11 DO SET
+12 QUIT
KILL ;
+1 KILL P,STAT,TYP,ORTX,N,JJ,DTOUT,%,C,HDT,I,LINE,ND4,NF,O,OK,ORIFN,PSGODT,PSJOCNT,Q,QQ,SD,ST,START,STOP,SUB,UDU,VAIP,VALMBCK,X1,X2
+2 QUIT
COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
+1 NEW OK
SET OK=0
+2 IF PSJCOM=0
SET OK=1
QUIT OK
+3 IF PSJCOM=""
QUIT OK
+4 IF PSJPTYP=""
QUIT OK
+5 IF '$DATA(^PS(53.1,"ACX",PSJCOM))
QUIT OK
+6 SET OK=1
IF PSJPTYP=3
QUIT OK
+7 NEW PSJON
SET PSJON=""
+8 FOR
SET PSJON=$ORDER(^PS(53.1,"ACX",PSJCOM,PSJON))
if 'PSJON
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",9)["D"
KILL ^PS(53.1,"ACX",PSJCOM)
+10 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",4)'="U"
IF PSJPTYP=1
SET OK=0
QUIT
+11 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",4)="U"
IF PSJPTYP=2
SET OK=0
QUIT
End DoDot:1
if OK=0
QUIT
+12 QUIT OK
PRMPTOR ; Prompt for order numbers
+1 KILL DIR
NEW PSJSELOR,PSJOTOT
SET PSJOTOT=+$GET(^TMP("PSJPRO",$JOB,0))
+2 SET PSJSELOR=$PIECE(XQORNOD(0),"=",2)
+3 SET DIR(0)="LO^"_$SELECT(+PSJOTOT:"1:"_+PSJOTOT,1:"")
SET DIR("A")=$SELECT($GET(PSJOTOT):"Select Orders",1:"Quit")
DO ^DIR
+4 IF ($GET(Y)<1)
SET VALMBCK="R"
QUIT
+5 SET PSJSELOR=$PIECE(Y(0),",",1,$LENGTH(Y(0),",")-1)
+6 DO PRMPTSD
+7 QUIT
PRMPTSD ; Prompt for start date/time
+1 NEW PSJQMSG,PSJNEWSD,TMPSELOR,TMPORDER,PSJABORT,PSJSYSW,PSJSYSW0,PSJCLSEL,PSJASTRK,PSJNWDTE,TMPSTR,TMPSTP,PSJREVFY,PSJMATCH,DFN,PSJTMPXQ,PSJNOLOK
+2 NEW CHKSEL,CHKSEL2,STAT,TMPO,TMPC,I
KILL DIR
+3 if $GET(XQORNOD)
SET PSJTMPXQ=XQORNOD
SET PSJNOLOK=0
+4 SET PSJSYSW0=""
SET PSJSYSW=0
SET PSJPWD=""
SET DFN=$GET(PSGP)
SET PSJREVFY=0
if '$DATA(PSGSS)
SET PSGSS=PSGSSAV
+5 IF '$GET(PSJPAD)
NEW PSJPAD
DO IN5^VADPT
SET PSJPAD=+VAIP(13,1)
+6 if '$GET(PSJSELOR)
SET PSJSELOR=$PIECE(XQORNOD(0),"=",2)
IF $DATA(^TMP("PSJCLOR",$JOB))
KILL ^TMP("PSJON",$JOB)
MERGE ^TMP("PSJON",$JOB)=^TMP("PSJCLOR",$JOB)
+7 DO ENCV^PSGSETU
SET $PIECE(PSJASTRK,"*",52)="*"
+8 SET TMPSELOR=PSJSELOR
+9 DO ORDCHK^PSJCLOR5
IF ($GET(PSJABORT)>1)
SET VALMBCK="R"
QUIT
+10 IF ($GET(TMPSELOR)'=$GET(PSJSELOR))
SET (Y,PSJSELOR)=TMPSELOR
+11 IF '$TRANSLATE(PSJSELOR,",")
Begin DoDot:1
+12 WRITE !," No editable orders have been selected - please re-select",!
DO CONT^PSJOE0
End DoDot:1
SET VALMBCK="R"
QUIT
+13 DO FULL^VALM1
FOR
DO PRMPTSD2
if '$GET(PSJQMSG)
QUIT
+14 IF '$GET(PSJNEWSD)!'$GET(PSJSELOR)
KILL PSJSELOR,VALMHDR
SET VALMBCK="R"
QUIT
+15 NEW PSJDTTMP
SET PSJDTTMP=$PIECE(PSJNEWSD,".")
FOR
SET PSJDTTMP=$ORDER(^PS(55,PSGP,5,"AUS",PSJDTTMP))
if 'PSJDTTMP
QUIT
SET PSJONTMP=0
FOR
SET PSJONTMP=$ORDER(^PS(55,PSGP,5,"AUS",PSJDTTMP,PSJONTMP))
if 'PSJONTMP
QUIT
Begin DoDot:1
+16 SET TMPC=""
FOR
SET TMPC=$ORDER(^TMP("PSJON",$JOB,TMPC))
if 'TMPC
QUIT
SET TMPO=^(TMPC)
IF TMPO["P"!(TMPO["U"&(+TMPO=+PSJONTMP))
IF ((","_PSJSELOR)[(","_TMPC_","))
SET PSJMATCH=-1
+17 FOR CHKSEL=1:1:$LENGTH(PSJSELOR,",")
if ($GET(PSJMATCH)<0)!(CHKSEL="")!'$DATA(^TMP("PSJON",$JOB,CHKSEL))
QUIT
SET CHKSEL2=$GET(^TMP("PSJON",$JOB,CHKSEL))
IF CHKSEL2=+PSJONTMP_"U"
SET PSJMATCH=-1
+18 IF ($GET(PSJMATCH)<0)
SET PSJMATCH=0
QUIT
+19 SET STAT=$PIECE($GET(^PS(55,PSGP,5,+PSJONTMP,0)),"^",9)
if STAT'="A"
QUIT
+20 IF ($PIECE($GET(^PS(55,PSGP,5,+PSJONTMP,2)),"^",2)<PSJNEWSD)&($PIECE($GET(^PS(55,PSGP,5,+PSJONTMP,2)),"^",4)>PSJNEWSD)
SET PSJMATCH=1
SET PSJMATCH(+PSJONTMP_"U")=""
QUIT
+21 IF $PIECE($PIECE($GET(^PS(55,PSGP,5,+PSJONTMP,2)),"^",2),".")=$PIECE(PSJNEWSD,"^")
SET PSJMATCH=1
SET PSJMATCH(+PSJONTMP_"U")=""
End DoDot:1
+22 NEW PSJDTTMP
SET PSJDTTMP=$PIECE(PSJNEWSD,".")
FOR
SET PSJDTTMP=$ORDER(^PS(55,PSGP,"IV","AIS",PSJDTTMP))
if 'PSJDTTMP
QUIT
SET PSJONTMP=0
FOR
SET PSJONTMP=$ORDER(^PS(55,PSGP,"IV","AIS",PSJDTTMP,PSJONTMP))
if 'PSJONTMP
QUIT
Begin DoDot:1
+23 SET TMPC=""
FOR
SET TMPC=$ORDER(^TMP("PSJON",$JOB,TMPC))
if 'TMPC
QUIT
SET TMPO=$GET(^(TMPC))
IF TMPO["P"!(TMPO["V"&(+TMPO=+PSJONTMP))
IF ((","_PSJSELOR)[(","_TMPC_","))
SET PSJMATCH=-1
+24 FOR CHKSEL=1:1:$LENGTH(PSJSELOR,",")
if ($GET(PSJMATCH)<0)!(CHKSEL="")
QUIT
SET CHKSEL2=$GET(^TMP("PSJON",$JOB,CHKSEL))
IF CHKSEL2=+PSJONTMP_"V"
SET PSJMATCH=-1
+25 IF ($GET(PSJMATCH)<0)
SET PSJMATCH=0
QUIT
+26 SET STAT=$PIECE($GET(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",17)
if STAT'="A"
QUIT
+27 IF $PIECE($GET(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",2)<PSJNEWSD&($PIECE($GET(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",3)>PSJNEWSD)
SET PSJMATCH=1
SET PSJMATCH(+PSJONTMP_"V")=""
QUIT
+28 IF $PIECE($PIECE($GET(^PS(55,PSGP,"IV",+PSJONTMP,0)),"^",2),".")=$PIECE(PSJNEWSD,".")
SET PSJMATCH=1
SET PSJMATCH(+PSJONTMP_"V")=""
End DoDot:1
+29 ;
+30 KILL TMPSTP,TMPSTR
NEW ND0,ND2,NDP1
+31 IF $GET(PSJNEWSD)
FOR PSJCLSEL=1:1:$LENGTH(PSJSELOR)
SET TMPSELOR=$PIECE(PSJSELOR,",",PSJCLSEL)
if 'TMPSELOR
QUIT
SET TMPORDER=$GET(^TMP("PSJON",$JOB,TMPSELOR))
if TMPORDER=""
QUIT
Begin DoDot:1
+32 SET ND0=$SELECT(TMPORDER["U":$GET(^PS(55,PSGP,5,+TMPORDER,0)),TMPORDER["P":$GET(^PS(53.1,+TMPORDER,0)),TMPORDER["V":$GET(^PS(55,PSGP,"IV",+TMPORDER,0)),1:"")
+33 SET ND2=$SELECT(TMPORDER["U":$GET(^PS(55,PSGP,5,+TMPORDER,2)),TMPORDER["P":$GET(^PS(53.1,+TMPORDER,2)),TMPORDER["V":$GET(^PS(55,PSGP,"IV",+TMPORDER,2)),1:"")
+34 SET TMPSTP=$SELECT(TMPORDER["U"!(TMPORDER["P"):$PIECE(ND2,"^",4),TMPORDER["V":$PIECE(ND0,"^",3),1:"")
IF TMPSTP<PSJNEWSD
SET TMPSTP($PIECE(TMPSTP,"."))=""
End DoDot:1
+35 ;
+36 IF $GET(PSJMATCH)!($ORDER(TMPSTP("")))!($DATA(PSJMATCH)>1)
Begin DoDot:1
+37 KILL DIR
NEW TMPCNT,PSJBLANK,PSJDASH
SET TMPCNT=1
DO FULL^VALM1
KILL DIR
NEW X,Y
SET DIR("A")="Do you want to view the profile"
SET DIR("A",TMPCNT)=" "
SET TMPCNT=$GET(TMPCNT)+1
+38 SET $PIECE(PSJBLANK," ",75)=""
SET $PIECE(PSJDASH,"-",75)="-"
+39 IF $ORDER(TMPSTP(""))
WRITE !!," * The new start date is after one or more stop date(s). * ",!," The stop date(s) will be automatically changed to reflect the new start date.",!
Begin DoDot:2
+40 NEW DIR
DO CONT^PSJOE0
End DoDot:2
+41 IF ($DATA(PSJMATCH)>1)
WRITE !!," * This patient has active order(s) on "_$$FMTE^XLFDT($PIECE(PSJNEWSD,"."))_". *"
Begin DoDot:2
+42 WRITE !,"Active Order(s)"_$EXTRACT(PSJBLANK,1,30)_"Current Start / Stop Dates",!,PSJDASH
End DoDot:2
+43 IF $GET(PSJMATCH)!($DATA(PSJMATCH)>1)
NEW TMPONST,TMPOINF,PSIVCNT
SET TMPONST=0
FOR PSIVCNT=1:1
SET TMPONST=$ORDER(PSJMATCH(TMPONST))
if 'TMPONST
QUIT
Begin DoDot:2
+44 NEW DSPLN,PSIVLCNT
KILL TMPOINF
SET TMPOINF=1
DO DSPORD^PSJCLOR2(PSGP,TMPONST,.TMPOINF)
SET DSPLN=0
FOR PSIVLCNT=1:1
SET DSPLN=$ORDER(TMPOINF(DSPLN))
if 'DSPLN
QUIT
Begin DoDot:3
+45 IF '(PSIVCNT#8)&(PSIVLCNT=1)
WRITE !
NEW DIR
DO CONT^PSJOE0
DO CLEAR^VALM1
DO FULL^VALM1
WRITE !,"Active Order(s) on "_$$FMTE^XLFDT($PIECE(PSJNEWSD,"."))_" (CONTINUED)",!!,"Active Order(s) (CONTINUED)"_$EXTRACT(PSJBLANK,1,20)_"Current Start / Stop Dates",!,PSJDASH
+46 WRITE !,TMPOINF(DSPLN)
End DoDot:3
End DoDot:2
+47 SET DIR("A",TMPCNT+1)=""
SET DIR(0)="Y"
DO ^DIR
SET PSJABORT=$SELECT(Y>0:0,(Y="^"):2,1:1)
+48 IF $GET(PSJABORT)
SET VALMBCK="R"
End DoDot:1
if ($GET(PSJABORT)=2)
QUIT
+49 IF $GET(PSJMATCH)!$ORDER(TMPSTP(""))!($DATA(PSJMATCH)>1)
IF '$GET(PSJABORT)
DO ^PSJHVARS
NEW VAIN,VADM,PSJLM
DO FULL^VALM1
DO ENOR^PSJCLOR4(PSGP)
DO RESTORE^PSJHVARS
SET VALMBCK="R"
+50 DO FULL^VALM1
WRITE !
+51 IF $GET(PSJNEWSD)
FOR PSJCLSEL=1:1:$LENGTH(PSJSELOR)
SET TMPSELOR=$PIECE(PSJSELOR,",",PSJCLSEL)
if 'TMPSELOR
QUIT
SET TMPORDER=$GET(^TMP("PSJON",$JOB,TMPSELOR))
if TMPORDER=""
QUIT
Begin DoDot:1
+52 IF PSJCLSEL=1
WRITE !,"Selected Orders:",?45,"Current Start / Stop Dates",!,$GET(PSJHLIN)
+53 DO DSPORD^PSJCLOR2(PSGP,TMPORDER)
IF '(PSJCLSEL#7)
NEW DIR
WRITE !
DO CONT^PSJOE0
DO CLEAR^VALM1
DO FULL^VALM1
WRITE !,"Selected Orders (CONTINUED):",?45,"Current Start / Stop Dates",!,$GET(PSJHLIN)
End DoDot:1
+54 IF $GET(PSJCLSEL)>1
WRITE !,$GET(PSJHLIN)
+55 ;
+56 SET PSJNWDTE=$PIECE($$FMTE^XLFDT(PSJNEWSD,2),":",1,2)
SET PSJNWDTE=$PIECE(PSJNWDTE,"@")_" "_$PIECE(PSJNWDTE,"@",2)
+57 KILL DIR,X,Y
SET DIR(0)="Y"
SET DIR("A",1)=" "
SET DIR("A",2)=" The Start Date/Time for the selected order"_$SELECT(($LENGTH(PSJSELOR,",")-2):"s",1:"")_" will"
+58 SET DIR("A",3)=" now be changed to "_PSJNWDTE
SET DIR("A",4)=" "
+59 SET DIR("A")=" "
SET DIR("A")="Are you sure "
DO ^DIR
IF '$GET(Y)
KILL PSJNEWSD
WRITE " ** NOTHING CHANGED **"
HANG 1
+60 KILL TMPARRAY
IF $GET(PSJNEWSD)
FOR PSJCLSEL=1:1:$LENGTH(PSJSELOR)
SET TMPSELOR=$PIECE(PSJSELOR,",",PSJCLSEL)
if 'TMPSELOR
QUIT
SET TMPORDER=$GET(^TMP("PSJON",$JOB,TMPSELOR))
if TMPORDER=""
QUIT
SET TMPARRAY($JOB,TMPSELOR)=TMPORDER
+61 IF $DATA(TMPARRAY)
IF $GET(PSJNEWSD)
FOR PSJCLSEL=1:1:$LENGTH(PSJSELOR)
SET TMPSELOR=$PIECE(PSJSELOR,",",PSJCLSEL)
if 'TMPSELOR
QUIT
SET TMPORDER=$GET(TMPARRAY($JOB,TMPSELOR))
if TMPORDER=""
QUIT
Begin DoDot:1
+62 NEW PSJDASH1,PSJDASH2
SET $PIECE(PSJDASH1,"-",70)="-"
SET PSJDASH2=PSJDASH1
FOR I=2:2:70
SET $EXTRACT(PSJDASH2,I)=" "
+63 WRITE !!,PSJDASH1,!,PSJDASH1,!,"Now working on order: "
DO DSPORD^PSJCLOR2(PSGP,TMPORDER)
+64 IF TMPORDER["U"!(TMPORDER["P")!(TMPORDER["V")
DO NEWORDER^PSJCLOR2(PSGP,TMPORDER,PSJNEWSD,$SELECT($GET(PSJREVFY):PSJREVFY,1:$GET(PSGOEAV)))
IF $GET(PSJNOLOK)
SET PSJNOLOK=0
QUIT
+65 IF PSJNEWSD>PSJEND
SET PSJEND=$PIECE(PSJNEWSD,".")_".24"
SET $PIECE(PSJTMPED,"^",2)=PSGP
+66 DO INIT^PSJCLOR2(3)
SET VALMBCK="R"
End DoDot:1
+67 KILL PSJSELOR,VALMHDR,TMPARRAY
SET VALMBCK="R"
+68 QUIT
PRMPTSD2 ;
+1 KILL DIR,X,Y
NEW TMPY
SET PSJQMSG=0
+2 KILL %DT
SET %DT("A")="Enter new Start Date/Time: "
SET %DT="TAE"
+3 DO ^%DT
if Y<0!($DATA(DTOUT))
QUIT
+4 SET TMPY=Y
IF TMPY["^"
SET PSJQMSG=0
QUIT
+5 IF $EXTRACT(TMPY)="?"
KILL DIR,X,Y
DO ENHLP^PSGOEM(55.06,10)
SET PSJQMSG=1
QUIT
+6 IF TMPY'["."
WRITE $CHAR(7),!?5," Time is REQUIRED. Re-enter Start Date. "
SET PSJQMSG=1
QUIT
+7 IF TMPY<($$FMADD^XLFDT(PSGDT,,,-1))
WRITE $CHAR(7),!?3,"Start Date/Time earlier than NOW is not allowed. Re-enter Start Date. "
SET PSJQMSG=1
QUIT
+8 IF TMPY>($$FMADD^XLFDT(PSGDT,365))
WRITE $CHAR(7),!?3,"Start Date cannot be more than 365 days from today. Re-enter Start Date."
SET PSJQMSG=1
QUIT
+9 SET TMPNEWSD=TMPY
+10 if $GET(PSJQMSG)
QUIT
+11 SET PSJNEWSD=TMPNEWSD
+12 QUIT
