PSIVUTL ;BIR/MLM-IV UTILITIES ;29-May-2012 14:37;PLS
;;5.0; INPATIENT MEDICATIONS ;**69,58,81,85,1009,110,133,1015**;16 DEC 97;Build 62
;
; Reference to ^DD("DD" is supported by DBIA 10017.
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PS(52.6 is supported y DBIA 1231.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; Reference to ^DIC is supported by DBIA 10006.
; Reference to ^PS(51.1 is supported by DBIA 2177.
;
;Modified - IHS/MSC/PLS - 08/20/10 - Line IVDRGSC+3
; 09/13/10 - Line DRGSC+5,IVDRGSC+3
DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting Orderable Items.
N OK,ND,NDU,NDI S OK=0
S ND=$G(^PS(50.7,+Y,0))
;I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
I OK N DLOOP F DLOOP=0:0 S DLOOP=$O(^PSDRUG("ASP",+Y,DLOOP)) Q:'DLOOP D Q:OK ;IHS/MSC/JDS screen if all drugs are screened
.S OK=$$SCREEN^APSPMULT(DLOOP)
Q OK
;
IVDRGSC(Y) ; Set DIC("S") for IV additive/solution selection.
; Naked reference below refers to full reference in Y, which is either ^PS(52.6, or ^PS(52.7
N Y S Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('+$P(X(1),U,11):0,'X(2):1,X(2)>DT:1,1:0)"
S Y=Y_" I $$SCREEN^APSPMULT(+$P($G(X(1)),U,2))" ;IHS/MSC/JDS - 9/13/2010 - MDF screening
Q Y
;
ENU(Y) ;Get IV additive strength.
N X S X=$P(^PS(52.6,+Y,0),U,3),Y=$$CODES^PSIVUTL(X,52.6,2)
Q Y
;
CODES(PSJCD,PSJF,PSJFLD) ; Get name from code.
; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
D FIELD^DID(PSJF,PSJFLD,"","POINTER","PSJDD")
S Y=$G(PSJDD("POINTER")) K PSJDD
S Y=$P($P(";"_Y,";"_PSJCD_":",2),";")
Q Y
;
CODES1(PSJCD,PSJF,PSJFLD) ;Check to see if code is valid.
; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
D FIELD^DID(PSJF,PSJFLD,"","POINTER","PSJDD")
I PSJDD("POINTER")'[PSJCD_":" K PSJDD Q 0
K PSJDD Q 1
;
CODES2(PSJF,PSJFLD) ;Get field name
; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
D FIELD^DID(PSJF,PSJFLD,"","LABEL","PSJDD")
Q PSJDD("LABEL")
;
GTPCI(Y) ; Set up "work" area for provider comments.
N DIC,DINUM,DLAYGO,X S DIC="^PS(53.45,",DIC(0)="LNZ",DLAYGO=53.45,(DINUM,X)=+DUZ D ^DIC
Q Y
;
WDTE(Y) ; Format and print date.
I 'Y S Y="******"
E X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
Q Y
GTOT(Y) ; Get order type & protocol
S P("OT")=$S(Y="A":"F",Y="H":"H",1:"I")
I P("OT")="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI I '$P(DRG(DRGT,DRGI),U,5) S P("OT")="I" Q
Q
;
PIV(ON) ; Display IV orders.
N DRG,ON55,P,PSJORIFN,TYP,X,Y S TYP="?" I ON["V" D
.S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
.S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
.S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
.W $S($P($G(^PS(55,DFN,"IV",+ON,.2)),U,4)="D":" d",1:" ")
.S X=$G(^PS(55,DFN,"IV",+ON,4)) I +PSJSYSU,'+$P(X,U,$S(+PSJSYSU=3:4,1:++PSJSYSU)) W "->"
I ON=+ON N O S O="" F S O=$O(^PS(53.1,"ACX",ON,O)) Q:O="" D
. S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+O,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) D PIV(O_"P") W !
I ON["P" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) I $E(P("OT"))="I" D Q
. NEW MARX,PSIVX D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,54,.MARX,0)
. F PSIVX=0:0 S PSIVX=$O(MARX(PSIVX)) Q:'PSIVX W @($S(PSIVX=1:"?9",1:"!?11")),MARX(PSIVX) D:PSIVX=1 PIV1
NEW DRGX S DRGX=0 F S DRGX=$O(DRG("AD",DRGX)) Q:'DRGX D PIVAD
SOL ;
NEW NAME
S DRGX=0 F S DRGX=$O(DRG("SOL",DRGX)) Q:'DRGX D
. D NAME(DRG("SOL",DRGX),39,.NAME,0)
. W:($D(DRG("AD",1))!(DRGX>1)) ! W:DRGX=1 ?9,"in "
. F X=0:0 S X=$O(NAME(X)) Q:'X W ?12 W NAME(X) I X=1,DRGX=1,'$D(DRG("AD",1)) D PIV1
Q
PIVAD ; Print IV Additives.
NEW NAME,PSGX
D NAME(DRG("AD",DRGX),39,.NAME,1)
F PSGX=0:0 S PSGX=$O(NAME(PSGX)) Q:'PSGX W:(DRGX'=1!(PSGX'=1)) ! W ?9,NAME(PSGX) I PSGX=1,DRGX=1 D PIV1
Q
;
PIV1 ; Print Sched type, start/stop dates, and status.
F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
I '$D(PSJEXTP) W ?50,TYP,?53,P(2),?60,P(3),?67,P(17) Q
W ?50,TYP,?53,P(2),?63,P(3),?73,P(17)
Q
59 ; Validate the Infusion rate entered using IV Quick order code.
N I F I=2,3,5,7,8,9,11,15,23 S P(I)=""
S P(4)="A",P(8)=$P($G(^PS(57.1,PSJQO,1)),U,5)
I $G(^PS(57.1,PSJQO,4,1,0)) S DRG("SOL",1)=^(0),DRG("SOL",0)=1
I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59
I X]"" D ENI^PSIVSP S:$D(X) P(8)=X
Q
WRTDRG(X,L) ; Format and print drug name, strength and bottle no.
N Y S Y=" "_$P(X,U,3) S:$P(X,U,4) Y=Y_" ("_$P(X,U,4)_")"
Q $E($P(X,U,2),1,(L-$L(Y)))_Y
;
NAME(X,L,MARX,AD) ; Format Additive display.
;INPUT : X=DRG("AD",DRG) L=Display length AD=for Additive(1/0)
;OUTPUT: AD(X) if X=2 that means there is a second line to display
N Y K MARX S Y=$P(X,U,3) S:(AD&$P(X,U,4)) Y=Y_" ("_$P(X,U,4)_")"
;* S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@"))
I 'AD!('$O(DRG("SOL",0))) D
.I $G(PSJL)[" in" S Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@")) Q
.I $G(DRGX)]"",DRGX'>1 S Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@")) Q
;I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)=" "_Y Q
I ($L($P(X,U,2))+$L(Y)+1)>L D TXT^PSGMUTL($P(X,U,2)_" "_Y,L) S:AD MARX(2)=" "_MARX(2) Q
S MARX(1)=$P(X,U,2)_" "_Y
Q
;
INTERVAL(IVAR) ;
N P,X,PSGOES M P=IVAR S X=$G(P(9)),PSGOES=1
D EN^PSIVSP S IVAR(15)=$S($G(P(15)):P(15),1:1440)
Q IVAR(15)
;
DOW(SCHED) ;
Q:SCHED="" 0
N P9,PSIVX,X S PSIVX=0 S P9=SCHED
; Use schedule validator
S X=SCHED D DW^PSGS0 I $G(X)="" Q 0
I +$O(^PS(51.1,"APPSJ",SCHED,0)) S PSIVX=1 S P9=$P(SCHED,"@") F X=1:1:$L(P9,"-") D Q:'$G(PSIVX)
. I '("MON,TUE,WED,THU,FRI,SAT,SUN"[$P(P9,"-",X)) S PSIVX=0 Q
Q:PSIVX +PSIVX
I '$D(^PS(51.1,"APPSJ",SCHED)) S PSIVX=1,P9=$P(SCHED,"@") F X=1:1:$L(P9,"-") D Q:'$G(PSIVX)
. I '(",MO,TU,WE,TH,FR,SA,SU,"[(","_$P(P9,"-",X)_",")) S PSIVX=0 Q
Q +PSIVX
PSIVUTL ;BIR/MLM-IV UTILITIES ;29-May-2012 14:37;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**69,58,81,85,1009,110,133,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^DD("DD" is supported by DBIA 10017.
+4 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+5 ; Reference to ^PS(52.6 is supported y DBIA 1231.
+6 ; Reference to ^PS(55 is supported by DBIA 2191.
+7 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+8 ; Reference to ^DIC is supported by DBIA 10006.
+9 ; Reference to ^PS(51.1 is supported by DBIA 2177.
+10 ;
+11 ;Modified - IHS/MSC/PLS - 08/20/10 - Line IVDRGSC+3
+12 ; 09/13/10 - Line DRGSC+5,IVDRGSC+3
DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting Orderable Items.
+1 NEW OK,ND,NDU,NDI
SET OK=0
+2 SET ND=$GET(^PS(50.7,+Y,0))
+3 ;I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
+4 SET OK=$SELECT('$PIECE(ND,U,4):1,$PIECE(ND,U,4)>DT:1,1:0)
+5 ;IHS/MSC/JDS screen if all drugs are screened
IF OK
NEW DLOOP
FOR DLOOP=0:0
SET DLOOP=$ORDER(^PSDRUG("ASP",+Y,DLOOP))
IF 'DLOOP
QUIT
Begin DoDot:1
+6 SET OK=$$SCREEN^APSPMULT(DLOOP)
End DoDot:1
IF OK
QUIT
+7 QUIT OK
+8 ;
IVDRGSC(Y) ; Set DIC("S") for IV additive/solution selection.
+1 ; Naked reference below refers to full reference in Y, which is either ^PS(52.6, or ^PS(52.7
+2 NEW Y
SET Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('+$P(X(1),U,11):0,'X(2):1,X(2)>DT:1,1:0)"
+3 ;IHS/MSC/JDS - 9/13/2010 - MDF screening
SET Y=Y_" I $$SCREEN^APSPMULT(+$P($G(X(1)),U,2))"
+4 QUIT Y
+5 ;
ENU(Y) ;Get IV additive strength.
+1 NEW X
SET X=$PIECE(^PS(52.6,+Y,0),U,3)
SET Y=$$CODES^PSIVUTL(X,52.6,2)
+2 QUIT Y
+3 ;
CODES(PSJCD,PSJF,PSJFLD) ; Get name from code.
+1 ; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
+2 DO FIELD^DID(PSJF,PSJFLD,"","POINTER","PSJDD")
+3 SET Y=$GET(PSJDD("POINTER"))
KILL PSJDD
+4 SET Y=$PIECE($PIECE(";"_Y,";"_PSJCD_":",2),";")
+5 QUIT Y
+6 ;
CODES1(PSJCD,PSJF,PSJFLD) ;Check to see if code is valid.
+1 ; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
+2 DO FIELD^DID(PSJF,PSJFLD,"","POINTER","PSJDD")
+3 IF PSJDD("POINTER")'[PSJCD_":"
KILL PSJDD
QUIT 0
+4 KILL PSJDD
QUIT 1
+5 ;
CODES2(PSJF,PSJFLD) ;Get field name
+1 ; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
+2 DO FIELD^DID(PSJF,PSJFLD,"","LABEL","PSJDD")
+3 QUIT PSJDD("LABEL")
+4 ;
GTPCI(Y) ; Set up "work" area for provider comments.
+1 NEW DIC,DINUM,DLAYGO,X
SET DIC="^PS(53.45,"
SET DIC(0)="LNZ"
SET DLAYGO=53.45
SET (DINUM,X)=+DUZ
DO ^DIC
+2 QUIT Y
+3 ;
WDTE(Y) ; Format and print date.
+1 IF 'Y
SET Y="******"
+2 IF '$TEST
XECUTE ^DD("DD")
SET Y=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+3 QUIT Y
GTOT(Y) ; Get order type & protocol
+1 SET P("OT")=$SELECT(Y="A":"F",Y="H":"H",1:"I")
+2 IF P("OT")="F"
FOR DRGT="AD","SOL"
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
IF 'DRGI
QUIT
IF '$PIECE(DRG(DRGT,DRGI),U,5)
SET P("OT")="I"
QUIT
+3 QUIT
+4 ;
PIV(ON) ; Display IV orders.
+1 NEW DRG,ON55,P,PSJORIFN,TYP,X,Y
SET TYP="?"
IF ON["V"
Begin DoDot:1
+2 SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
FOR X=2,3,4,5,8,9,17,23
SET P(X)=$PIECE(Y,U,X)
+3 SET TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
IF TYP'="O"
SET TYP="C"
+4 SET ON55=ON
SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"H",1:"I")
DO GTDRG^PSIVORFB
DO GTOT^PSIVUTL(P(4))
+5 WRITE $SELECT($PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),U,4)="D":" d",1:" ")
+6 SET X=$GET(^PS(55,DFN,"IV",+ON,4))
IF +PSJSYSU
IF '+$PIECE(X,U,$SELECT(+PSJSYSU=3:4,1:++PSJSYSU))
WRITE "->"
End DoDot:1
+7 IF ON=+ON
NEW O
SET O=""
FOR
SET O=$ORDER(^PS(53.1,"ACX",ON,O))
IF O=""
QUIT
Begin DoDot:1
+8 SET (P(2),P(3))=""
SET P(17)=$PIECE($GET(^PS(53.1,+O,0)),U,9)
SET Y=$GET(^(8))
SET P(4)=$PIECE(Y,U)
SET P(8)=$PIECE(Y,U,5)
SET P(9)=$PIECE($GET(^(2)),U)
DO GTDRG^PSIVORFA
DO GTOT^PSIVUTL(P(4))
DO PIV(O_"P")
WRITE !
End DoDot:1
+9 IF ON["P"
SET (P(2),P(3))=""
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
SET Y=$GET(^(8))
SET P(4)=$PIECE(Y,U)
SET P(8)=$PIECE(Y,U,5)
SET P(9)=$PIECE($GET(^(2)),U)
DO GTDRG^PSIVORFA
DO GTOT^PSIVUTL(P(4))
IF $EXTRACT(P("OT"))="I"
Begin DoDot:1
+10 NEW MARX,PSIVX
DO DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,54,.MARX,0)
+11 FOR PSIVX=0:0
SET PSIVX=$ORDER(MARX(PSIVX))
IF 'PSIVX
QUIT
WRITE @($SELECT(PSIVX=1:"?9",1:"!?11")),MARX(PSIVX)
IF PSIVX=1
DO PIV1
End DoDot:1
QUIT
+12 NEW DRGX
SET DRGX=0
FOR
SET DRGX=$ORDER(DRG("AD",DRGX))
IF 'DRGX
QUIT
DO PIVAD
SOL ;
+1 NEW NAME
+2 SET DRGX=0
FOR
SET DRGX=$ORDER(DRG("SOL",DRGX))
IF 'DRGX
QUIT
Begin DoDot:1
+3 DO NAME(DRG("SOL",DRGX),39,.NAME,0)
+4 IF ($DATA(DRG("AD",1))!(DRGX>1))
WRITE !
IF DRGX=1
WRITE ?9,"in "
+5 FOR X=0:0
SET X=$ORDER(NAME(X))
IF 'X
QUIT
WRITE ?12
WRITE NAME(X)
IF X=1
IF DRGX=1
IF '$DATA(DRG("AD",1))
DO PIV1
End DoDot:1
+6 QUIT
PIVAD ; Print IV Additives.
+1 NEW NAME,PSGX
+2 DO NAME(DRG("AD",DRGX),39,.NAME,1)
+3 FOR PSGX=0:0
SET PSGX=$ORDER(NAME(PSGX))
IF 'PSGX
QUIT
IF (DRGX'=1!(PSGX'=1))
WRITE !
WRITE ?9,NAME(PSGX)
IF PSGX=1
IF DRGX=1
DO PIV1
+4 QUIT
+5 ;
PIV1 ; Print Sched type, start/stop dates, and status.
+1 FOR X=2,3
SET P(X)=$EXTRACT($$ENDTC^PSGMI(P(X)),1,$SELECT($DATA(PSJEXTP):8,1:5))
+2 IF '$DATA(PSJEXTP)
WRITE ?50,TYP,?53,P(2),?60,P(3),?67,P(17)
QUIT
+3 WRITE ?50,TYP,?53,P(2),?63,P(3),?73,P(17)
+4 QUIT
59 ; Validate the Infusion rate entered using IV Quick order code.
+1 NEW I
FOR I=2,3,5,7,8,9,11,15,23
SET P(I)=""
+2 SET P(4)="A"
SET P(8)=$PIECE($GET(^PS(57.1,PSJQO,1)),U,5)
+3 IF $GET(^PS(57.1,PSJQO,4,1,0))
SET DRG("SOL",1)=^(0)
SET DRG("SOL",0)=1
+4 IF X["?"
SET F1=53.1
SET F2=59
DO ENHLP^PSIVORC1
GOTO 59
+5 IF X]""
DO ENI^PSIVSP
IF $DATA(X)
SET P(8)=X
+6 QUIT
WRTDRG(X,L) ; Format and print drug name, strength and bottle no.
+1 NEW Y
SET Y=" "_$PIECE(X,U,3)
IF $PIECE(X,U,4)
SET Y=Y_" ("_$PIECE(X,U,4)_")"
+2 QUIT $EXTRACT($PIECE(X,U,2),1,(L-$LENGTH(Y)))_Y
+3 ;
NAME(X,L,MARX,AD) ; Format Additive display.
+1 ;INPUT : X=DRG("AD",DRG) L=Display length AD=for Additive(1/0)
+2 ;OUTPUT: AD(X) if X=2 that means there is a second line to display
+3 NEW Y
KILL MARX
SET Y=$PIECE(X,U,3)
IF (AD&$PIECE(X,U,4))
SET Y=Y_" ("_$PIECE(X,U,4)_")"
+4 ;* S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@"))
+5 IF 'AD!('$ORDER(DRG("SOL",0)))
Begin DoDot:1
+6 IF $GET(PSJL)[" in"
SET Y=Y_" "_$SELECT(P(4)="P"!($GET(P(23))="P")!$GET(P(5)):P(9),1:$PIECE(P(8),"@"))
QUIT
+7 IF $GET(DRGX)]""
IF DRGX'>1
SET Y=Y_" "_$SELECT(P(4)="P"!($GET(P(23))="P")!$GET(P(5)):P(9),1:$PIECE(P(8),"@"))
QUIT
End DoDot:1
+8 ;I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)=" "_Y Q
+9 IF ($LENGTH($PIECE(X,U,2))+$LENGTH(Y)+1)>L
DO TXT^PSGMUTL($PIECE(X,U,2)_" "_Y,L)
IF AD
SET MARX(2)=" "_MARX(2)
QUIT
+10 SET MARX(1)=$PIECE(X,U,2)_" "_Y
+11 QUIT
+12 ;
INTERVAL(IVAR) ;
+1 NEW P,X,PSGOES
MERGE P=IVAR
SET X=$GET(P(9))
SET PSGOES=1
+2 DO EN^PSIVSP
SET IVAR(15)=$SELECT($GET(P(15)):P(15),1:1440)
+3 QUIT IVAR(15)
+4 ;
DOW(SCHED) ;
+1 IF SCHED=""
QUIT 0
+2 NEW P9,PSIVX,X
SET PSIVX=0
SET P9=SCHED
+3 ; Use schedule validator
+4 SET X=SCHED
DO DW^PSGS0
IF $GET(X)=""
QUIT 0
+5 IF +$ORDER(^PS(51.1,"APPSJ",SCHED,0))
SET PSIVX=1
SET P9=$PIECE(SCHED,"@")
FOR X=1:1:$LENGTH(P9,"-")
Begin DoDot:1
+6 IF '("MON,TUE,WED,THU,FRI,SAT,SUN"[$PIECE(P9,"-",X))
SET PSIVX=0
QUIT
End DoDot:1
IF '$GET(PSIVX)
QUIT
+7 IF PSIVX
QUIT +PSIVX
+8 IF '$DATA(^PS(51.1,"APPSJ",SCHED))
SET PSIVX=1
SET P9=$PIECE(SCHED,"@")
FOR X=1:1:$LENGTH(P9,"-")
Begin DoDot:1
+9 IF '(",MO,TU,WE,TH,FR,SA,SU,"[(","_$PIECE(P9,"-",X)_","))
SET PSIVX=0
QUIT
End DoDot:1
IF '$GET(PSIVX)
QUIT
+10 QUIT +PSIVX
