PSIVUTL.m

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