PSJ0103 ;BIR/JLC - Check for Non-Standard Schedules ;01-MAR-04
;;5.0; INPATIENT MEDICATIONS ;**103**;16 DEC 97
;
;Reference to ^PS(50.606 is supported by DBIA# 2174.
;Reference to ^PS(50.7 is supported by DBIA# 2180.
;Reference to ^PS(51.1 is supported by DBIA# 2177.
;Reference to ^PS(52.6 is supported by DBIA# 1231.
;Reference to ^PS(55 is supported by DBIA# 2191.
;
ENNV ;
I $G(DUZ)="" W !,"Your DUZ is not defined." Q
W !,"NUMBER OF DAYS: 365// " R X:DTIME I X="^"!'$T Q
I X="" S X=365
I X'?1.3N!(X<0)!(X?1.2"?") W:X'?1.2"?" $C(7) W "Must be number, 1-999 days." G ENNV
S PSJDAYS=X K ZTSAVE,ZTSK S ZTSAVE("PSJDAYS")="",ZTRTN="ENQN^PSJ0103",ZTDESC="Schedule Search",ZTIO="" D ^%ZTLOAD
W !!,"The check of Pharmacy orders is",$S($D(ZTSK):"",1:" NOT")," queued",!
I $D(ZTSK) W " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
Q
ENQN ;
N PSJBEG,PSJPDFN,PSJORD,PSJSCHD,CREAT,EXPR,OCNT,PSJND0,PSJND2,X,A,S1,S2,OK
D NOW^%DTC S CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0) K ^XTMP("PSJSC") S PSJSCHD=0
F S PSJSCHD=$O(^PS(51.1,"AC","PSJ",PSJSCHD)) Q:PSJSCHD="" I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","DAN51.1",PSJSCHD)=""
S %H=$H-PSJDAYS D YMD^%DTC S PSJBEG=X F S PSJBEG=$O(^PS(55,"AUDS",PSJBEG)) Q:PSJBEG="" S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,"AUDS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
. S PSJORD=0 F S PSJORD=$O(^PS(55,"AUDS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
.. S PSJND2=$G(^PS(55,PSJPDFN,5,PSJORD,2)),PSJND0=^(0),PSJSCHD=$P(PSJND2,"^") D
... S ^XTMP("PSJSC","ALL",PSJSCHD)=""
... I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","DAN",PSJSCHD)="" I $P(PSJND0,"^",9)="A" S ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$P(PSJND0,"^",2)_"^"_$P(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
... I $D(^PS(51.1,"AC","PSJ",PSJSCHD)) Q
... D MISC(PSJSCHD) Q:OK
... S ^XTMP("PSJSC","NSS",PSJSCHD)="" I $P(PSJND0,"^",9)="A" S ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$P(PSJND0,"^",2)_"^"_$P(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
S %H=$H-PSJDAYS D YMD^%DTC S PSJBEG=X F S PSJBEG=$O(^PS(55,"AIVS",PSJBEG)) Q:PSJBEG="" S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
. S PSJORD=0 F S PSJORD=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
.. S PSJND0=$G(^PS(55,PSJPDFN,"IV",PSJORD,0)),PSJSCHD=$P(PSJND0,"^",9) I PSJSCHD]"" D
... S ^XTMP("PSJSC","ALL",PSJSCHD)=""
... S ITEM="" S A=$O(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0)) I A S ITEM="A^"_$P(^(A,0),"^")_"^"_$P(^(0),"^",2)
... I ITEM="" S A=$O(^PS(55,PSJPDFN,"IV",PSJORD,"SOL",0)) I A S ITEM="S^"_$P(^(A,0),"^")_"^"_$P(^(0),"^",2)
... I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","DAN",PSJSCHD)="" I $P(PSJND0,"^",17)="A" S ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$P(PSJND0,"^",6)_"^"_ITEM
... I $D(^PS(51.1,"AC","PSJ",PSJSCHD)) Q
... D MISC(PSJSCHD) Q:OK
... S ^XTMP("PSJSC","NSS",PSJSCHD)="" I $P(PSJND0,"^",17)="A" S ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$P(PSJND0,"^",6)_"^"_ITEM
S S1=0 F S S1=$O(^PS(52.6,S1)) Q:'S1 D
. S A=$G(^PS(52.6,S1,0)),PSJSCHD=$P(A,"^",5) Q:PSJSCHD=""
. I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","QC","NSS",$P(A,"^"))=""
. I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","QC","DAN",$P(A,"^"))=""
. S S2=0 F S S2=$O(^PS(52.6,S1,1,S2)) Q:'S2 D
.. S A=$G(^PS(52.6,S1,1,S2,0)),PSJSCHD=$P(A,"^",5) Q:PSJSCHD=""
.. I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","QC","NSS",$P(A,"^"))=""
.. I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","QC","DAN",$P(A,"^"))=""
S S1=0 F S S1=$O(^PS(53.2,S1)) Q:'S1 D
. S S2=0 F S S2=$O(^PS(53.2,S1,2,S2)) Q:'S2 D
.. S A=$G(^PS(53.2,S1,2,S2,0)),PSJSCHD=$P(A,"^",5) Q:PSJSCHD=""
.. I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","OS","NSS",$P(^PS(53.2,S1,0),"^"))=""
.. I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","OS","DAN",$P(^PS(53.2,S1,0),"^"))=""
S S1=0 F S S1=$O(^PS(50.7,S1)) Q:'S1 D
. S A=^PS(50.7,S1,0),PSJSCHD=$P(A,"^",8),PSJDOF=$$GET1^DIQ(50.606,$P(A,"^",2),.01) Q:PSJSCHD=""
. I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","OI","NSS",$P(A,"^"))=PSJDOF
. I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","OI","DAN",$P(A,"^"))=PSJDOF
S:$D(^XTMP("PSJSC")) ^XTMP("PSJSC",0)=EXPR_"^"_CREAT
D SENDMSG^PSJA0103
DONE ;
K PSG,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK S ZTREQ="@"
Q
DANGER(A) ;
N B,C,BAD
S B=$TR(A,".",""),BAD=0
F I=1:1:$L(B," ") S C=$P(B," ",I) I C="QD"!(C="QOD")!(C="HS")!(C="TIW")!(C="QHS") S BAD=1 Q
Q BAD
MISC(X) ;
N A,I,C
S OK=1 I X["PRN" D Q
. S C=$L(X," ") F I=1:1:C S A=$P(X," ",I) S:A="PRN" X=$P(X," ",1,I-1) I I<C S X=X_" "_$P(X," ",I+2,99)
. I X="" S OK=0 Q
. I '$D(^PS(51.1,"AC","PSJ",X)) S OK=0
I X?2.4N1"-".E!(X?2.4N) D ENCHK I '$D(X) S OK=0 Q
D DW I '$D(X) S OK=0
Q
ENCHK ;
I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
S X(1)=$L(X(1)) I X'["-",X>$E(2400,1,X(1)) K X Q
F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
K:$D(X) X(1),X(2),X(3) Q
;
DW ;
S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2)
I X]"" D ENCHK Q:'$D(X)
S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-" F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q
F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD="" S Z=$P(X,X(1),Q) D DWC Q:'$D(X)
K X(1) S:$D(X) X=SDW Q
DWC I $L(Z)<2 K X Q
F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q
E K X
Q
PSJ0103 ;BIR/JLC - Check for Non-Standard Schedules ;01-MAR-04
+1 ;;5.0; INPATIENT MEDICATIONS ;**103**;16 DEC 97
+2 ;
+3 ;Reference to ^PS(50.606 is supported by DBIA# 2174.
+4 ;Reference to ^PS(50.7 is supported by DBIA# 2180.
+5 ;Reference to ^PS(51.1 is supported by DBIA# 2177.
+6 ;Reference to ^PS(52.6 is supported by DBIA# 1231.
+7 ;Reference to ^PS(55 is supported by DBIA# 2191.
+8 ;
ENNV ;
+1 IF $GET(DUZ)=""
WRITE !,"Your DUZ is not defined."
QUIT
+2 WRITE !,"NUMBER OF DAYS: 365// "
READ X:DTIME
IF X="^"!'$TEST
QUIT
+3 IF X=""
SET X=365
+4 IF X'?1.3N!(X<0)!(X?1.2"?")
IF X'?1.2"?"
WRITE $CHAR(7)
WRITE "Must be number, 1-999 days."
GOTO ENNV
+5 SET PSJDAYS=X
KILL ZTSAVE,ZTSK
SET ZTSAVE("PSJDAYS")=""
SET ZTRTN="ENQN^PSJ0103"
SET ZTDESC="Schedule Search"
SET ZTIO=""
DO ^%ZTLOAD
+6 WRITE !!,"The check of Pharmacy orders is",$SELECT($DATA(ZTSK):"",1:" NOT")," queued",!
+7 IF $DATA(ZTSK)
WRITE " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
+8 QUIT
ENQN ;
+1 NEW PSJBEG,PSJPDFN,PSJORD,PSJSCHD,CREAT,EXPR,OCNT,PSJND0,PSJND2,X,A,S1,S2,OK
+2 DO NOW^%DTC
SET CREAT=$EXTRACT(%,1,7)
SET EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
KILL ^XTMP("PSJSC")
SET PSJSCHD=0
+3 FOR
SET PSJSCHD=$ORDER(^PS(51.1,"AC","PSJ",PSJSCHD))
IF PSJSCHD=""
QUIT
IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","DAN51.1",PSJSCHD)=""
+4 SET %H=$HOROLOG-PSJDAYS
DO YMD^%DTC
SET PSJBEG=X
FOR
SET PSJBEG=$ORDER(^PS(55,"AUDS",PSJBEG))
IF PSJBEG=""
QUIT
SET PSJPDFN=0
FOR
SET PSJPDFN=$ORDER(^PS(55,"AUDS",PSJBEG,PSJPDFN))
IF 'PSJPDFN
QUIT
Begin DoDot:1
+5 SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,"AUDS",PSJBEG,PSJPDFN,PSJORD))
IF 'PSJORD
QUIT
Begin DoDot:2
+6 SET PSJND2=$GET(^PS(55,PSJPDFN,5,PSJORD,2))
SET PSJND0=^(0)
SET PSJSCHD=$PIECE(PSJND2,"^")
Begin DoDot:3
+7 SET ^XTMP("PSJSC","ALL",PSJSCHD)=""
+8 IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","DAN",PSJSCHD)=""
IF $PIECE(PSJND0,"^",9)="A"
SET ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$PIECE(PSJND0,"^",2)_"^"_$PIECE(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
+9 IF $DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
QUIT
+10 DO MISC(PSJSCHD)
IF OK
QUIT
+11 SET ^XTMP("PSJSC","NSS",PSJSCHD)=""
IF $PIECE(PSJND0,"^",9)="A"
SET ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$PIECE(PSJND0,"^",2)_"^"_$PIECE(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET %H=$HOROLOG-PSJDAYS
DO YMD^%DTC
SET PSJBEG=X
FOR
SET PSJBEG=$ORDER(^PS(55,"AIVS",PSJBEG))
IF PSJBEG=""
QUIT
SET PSJPDFN=0
FOR
SET PSJPDFN=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN))
IF 'PSJPDFN
QUIT
Begin DoDot:1
+13 SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD))
IF 'PSJORD
QUIT
Begin DoDot:2
+14 SET PSJND0=$GET(^PS(55,PSJPDFN,"IV",PSJORD,0))
SET PSJSCHD=$PIECE(PSJND0,"^",9)
IF PSJSCHD]""
Begin DoDot:3
+15 SET ^XTMP("PSJSC","ALL",PSJSCHD)=""
+16 SET ITEM=""
SET A=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0))
IF A
SET ITEM="A^"_$PIECE(^(A,0),"^")_"^"_$PIECE(^(0),"^",2)
+17 IF ITEM=""
SET A=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"SOL",0))
IF A
SET ITEM="S^"_$PIECE(^(A,0),"^")_"^"_$PIECE(^(0),"^",2)
+18 IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","DAN",PSJSCHD)=""
IF $PIECE(PSJND0,"^",17)="A"
SET ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$PIECE(PSJND0,"^",6)_"^"_ITEM
+19 IF $DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
QUIT
+20 DO MISC(PSJSCHD)
IF OK
QUIT
+21 SET ^XTMP("PSJSC","NSS",PSJSCHD)=""
IF $PIECE(PSJND0,"^",17)="A"
SET ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$PIECE(PSJND0,"^",6)_"^"_ITEM
End DoDot:3
End DoDot:2
End DoDot:1
+22 SET S1=0
FOR
SET S1=$ORDER(^PS(52.6,S1))
IF 'S1
QUIT
Begin DoDot:1
+23 SET A=$GET(^PS(52.6,S1,0))
SET PSJSCHD=$PIECE(A,"^",5)
IF PSJSCHD=""
QUIT
+24 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
DO MISC(PSJSCHD)
IF 'OK
SET ^XTMP("PSJSC","QC","NSS",$PIECE(A,"^"))=""
+25 IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","QC","DAN",$PIECE(A,"^"))=""
+26 SET S2=0
FOR
SET S2=$ORDER(^PS(52.6,S1,1,S2))
IF 'S2
QUIT
Begin DoDot:2
+27 SET A=$GET(^PS(52.6,S1,1,S2,0))
SET PSJSCHD=$PIECE(A,"^",5)
IF PSJSCHD=""
QUIT
+28 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
DO MISC(PSJSCHD)
IF 'OK
SET ^XTMP("PSJSC","QC","NSS",$PIECE(A,"^"))=""
+29 IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","QC","DAN",$PIECE(A,"^"))=""
End DoDot:2
End DoDot:1
+30 SET S1=0
FOR
SET S1=$ORDER(^PS(53.2,S1))
IF 'S1
QUIT
Begin DoDot:1
+31 SET S2=0
FOR
SET S2=$ORDER(^PS(53.2,S1,2,S2))
IF 'S2
QUIT
Begin DoDot:2
+32 SET A=$GET(^PS(53.2,S1,2,S2,0))
SET PSJSCHD=$PIECE(A,"^",5)
IF PSJSCHD=""
QUIT
+33 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
DO MISC(PSJSCHD)
IF 'OK
SET ^XTMP("PSJSC","OS","NSS",$PIECE(^PS(53.2,S1,0),"^"))=""
+34 IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","OS","DAN",$PIECE(^PS(53.2,S1,0),"^"))=""
End DoDot:2
End DoDot:1
+35 SET S1=0
FOR
SET S1=$ORDER(^PS(50.7,S1))
IF 'S1
QUIT
Begin DoDot:1
+36 SET A=^PS(50.7,S1,0)
SET PSJSCHD=$PIECE(A,"^",8)
SET PSJDOF=$$GET1^DIQ(50.606,$PIECE(A,"^",2),.01)
IF PSJSCHD=""
QUIT
+37 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
DO MISC(PSJSCHD)
IF 'OK
SET ^XTMP("PSJSC","OI","NSS",$PIECE(A,"^"))=PSJDOF
+38 IF $$DANGER(PSJSCHD)
SET ^XTMP("PSJSC","OI","DAN",$PIECE(A,"^"))=PSJDOF
End DoDot:1
+39 IF $DATA(^XTMP("PSJSC"))
SET ^XTMP("PSJSC",0)=EXPR_"^"_CREAT
+40 DO SENDMSG^PSJA0103
DONE ;
+1 KILL PSG,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK
SET ZTREQ="@"
+2 QUIT
DANGER(A) ;
+1 NEW B,C,BAD
+2 SET B=$TRANSLATE(A,".","")
SET BAD=0
+3 FOR I=1:1:$LENGTH(B," ")
SET C=$PIECE(B," ",I)
IF C="QD"!(C="QOD")!(C="HS")!(C="TIW")!(C="QHS")
SET BAD=1
QUIT
+4 QUIT BAD
MISC(X) ;
+1 NEW A,I,C
+2 SET OK=1
IF X["PRN"
Begin DoDot:1
+3 SET C=$LENGTH(X," ")
FOR I=1:1:C
SET A=$PIECE(X," ",I)
IF A="PRN"
SET X=$PIECE(X," ",1,I-1)
IF I<C
SET X=X_" "_$PIECE(X," ",I+2,99)
+4 IF X=""
SET OK=0
QUIT
+5 IF '$DATA(^PS(51.1,"AC","PSJ",X))
SET OK=0
End DoDot:1
QUIT
+6 IF X?2.4N1"-".E!(X?2.4N)
DO ENCHK
IF '$DATA(X)
SET OK=0
QUIT
+7 DO DW
IF '$DATA(X)
SET OK=0
+8 QUIT
ENCHK ;
+1 IF $SELECT($LENGTH($PIECE(X,"-"))>4:1,$LENGTH(X)>119:1,$LENGTH(X)<2:1,X'>0:1,1:X'?.ANP)
KILL X
QUIT
+2 SET X(1)=$PIECE(X,"-")
IF X(1)'?2N
IF X(1)'?4N
KILL X
QUIT
+3 SET X(1)=$LENGTH(X(1))
IF X'["-"
IF X>$EXTRACT(2400,1,X(1))
KILL X
QUIT
+4 FOR X(2)=2:1:$LENGTH(X,"-")
SET X(3)=$PIECE(X,"-",X(2))
IF $SELECT($LENGTH(X(3))'=X(1):1,X(3)>$EXTRACT(2400,1,X(1)):1,1:X(3)'>$PIECE(X,"-",X(2)-1))
KILL X
QUIT
+5 IF $DATA(X)
KILL X(1),X(2),X(3)
QUIT
+6 ;
DW ;
+1 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
SET SDW=X
SET X=$PIECE(X,"@",2)
+2 IF X]""
DO ENCHK
IF '$DATA(X)
QUIT
+3 SET X=$PIECE(SDW,"@")
SET X(1)="-"
IF X?.E1P.E
IF X'["-"
FOR QX=1:1:$LENGTH(X)
IF $EXTRACT(X,QX)?1P
SET X(1)=$EXTRACT(X,QX)
QUIT
+4 FOR Q=1:1:$LENGTH(X,X(1))
IF SWD=""
KILL X
IF SWD=""
QUIT
SET Z=$PIECE(X,X(1),Q)
DO DWC
IF '$DATA(X)
QUIT
+5 KILL X(1)
IF $DATA(X)
SET X=SDW
QUIT
DWC IF $LENGTH(Z)<2
KILL X
QUIT
+1 FOR QX=1:1:$LENGTH(SWD,"^")
SET Y=$PIECE(SWD,"^",QX)
IF $PIECE(Y,Z)=""
SET SWD=$PIECE(SWD,Y,2)
IF $LENGTH(SWD)
SET SWD=$EXTRACT(SWD,2,50)
QUIT
+2 IF '$TEST
KILL X
+3 QUIT
