PSJCLOR3.m

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 ---PSJCLOR3   14741     printed  Mar 13, 2025@21:11:18                                                                                                                                                                                                   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")