PSIVWL1.m

PSIVWL1 ;BIR/RGY-WARD LIST ROUTINES ;02 AUG 96 / 9:40 AM

 ;;5.0; INPATIENT MEDICATIONS ;**81**;16 DEC 97

 ;

 ; Reference to ^PS(55 is supported by DBIA 2191

 ; Reference to ^VA(200 is supported by DBIA 10060

 ;

SELMAN ;

 K PSM,PSIVMT,PSIVOD,PSIVCD S PSCT=0 F I=0:0 S I=$O(^PS(59.5,PSIVSN,2,I)) Q:'I  S PSM(I)=^(I,0),PSCT=PSCT+1

P W !!?5,"The manufacturing times on file are:"

P0 F I=0:0 S I=$O(PSM(I)) Q:'I  S X=PSM(I) W !?10,I,"  ",$E($P(X,"^",5),1,2),":",$E($P(X,"^",5),3,4),"   ",$$CODES^PSIVUTL($P(X,"^",2),59.51,.02)_" covering ",$P(X,"^",3),"."

ASK ;

 S X="Enter manufacturing time(s):^^^^QUX=+QUX!(QUX["","")!(QUX="""")" D ENQ^PSIV Q:X["^"!(X="")  S PSM=X F I=1:1 S X=$P(PSM,",",I) Q:X=""  I '$D(PSM(X)) S PSM="*" Q

 I PSM="*" S HELP="ASKMAN" D ^PSIVHLP G P

SEL F PSIV=1:1 S I=$P(PSM,",",PSIV) Q:I=""  S PSIVMT($P(PSM(I),"^",2))=+(PSIVDT_"."_$P(PSM(I),"^",5)),PSIVOD($P(PSM(I),"^",2))=+(PSIVDT_"."_$P(PSM(I),"^")),PSIVCD($P(PSM(I),"^",2))=+(PSIVDT_"."_$P(PSM(I),"^",4)) D SEL1

 W ! S X=PSM K PSM Q

SEL1 I $P(PSM(I),"^")>$P(PSM(I),"^",4) S X1=PSIVDT,X2=1 D C^%DTC S X=$P(X,".") S $P(PSIVCD($P(PSM(I),"^",2)),".")=X ; INSTALL WITH V 17.3 OF FILEMAN

 Q

ENRSET W ! S X="Are you sure you want to RESET the Ward List (Y/N) ?^N" D ENYN^PSIV Q:"N^"[$E(X)  I X="?" S HELP="RESWL" D ^PSIVHLP1 G ENRSET

 D SELMAN F I=1:1 S Y=$P(X,",",I) Q:'Y  S $P(^PS(59.5,PSIVSN,2,Y,0),"^",6)=PSIVDT W !,"... Ward list #",$P(X,",",I)," reset"

 Q

PRNT ;

 D HDR:$Y+7>IOSL!(PSIVWARD'=WRD),INP^VADPT

 W !,VAIN(5),?30 S PSIV=$O(^PS(55,DFN,"IV",ON,"AD",0)) D:PSIV ENP2^PSIVRNL W ?70 S Y=P(3) D WD W ?92,+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON),?100 W $P($G(^VA(200,+P(6),0)),U)

 W !,PSIV("NME") S SSNF=0 D ENP3^PSIVRNL Q

HDR W:$Y @IOF W !,"WARD LIST FOR IV ROOM: ",$P(^PS(59.5,PSIVSN,0),U)," AT " S Y=PSIVDT X ^DD("DD") W $P(Y,"@"),?70,"Printed on   : " S Y=PSIVRUN,UWLTY="" X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) W !

 F I=0:0 S UWLTY=$O(PSIVOD(UWLTY)) Q:UWLTY=""  S X=$$CODES^PSIVUTL(UWLTY,55.01,.04) W !,X,"S",?15," covering from " S Y=PSIVOD(UWLTY) D WD W " to " S Y=PSIVCD(UWLTY) D WD W "  Manufacturing time: " S Y=PSIVMT(UWLTY) D WD

 Q:NOFLG=1  W !!?92,"Qty",!,"Patient name",?40,"Order",?70,"Stop date",?90,"needed",?100,"Provider/Initial"

 W ! F X=1:1:110 W "-" W:X=50 " Ward: ",WRD," "

 S PSIVWARD=WRD

 K UWLTY

 Q

SETP S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)

 Q

WD X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) Q

CODES S X=$P($P(";"_$P(Y,"^",3),";"_X_":",2),";") Q

ENT ;

 ;Will print ward list

NOW D NOW^%DTC S PSIVRUN=$E(%,1,12),PSIVWARD="" K %,%I,%H

 S WRD="",NOFLG=1 F JX=0:0 S WRD=$O(^PS(55,"PSIVWL",PSIVSN,WRD)) Q:WRD=""  S PSIVT="" F JX=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT=""  S PSIVDT=PSIVOD(PSIVT) D NOW1

 W:NOFLG !!,"****NO DATA FOUND FOR THE WARD LIST WITH THE SELECTED IV TYPE(S)!****"

 G QPRNT

 Q

NOW1 F DFN=0:0 S DFN=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN)) Q:'DFN  S PSIV("NME")=$P($G(^DPT(DFN,0)),U) D PID^VADPT,NXT

 Q

QPRNT K JX,PSIVT,PSIVWARD,PSIVDT,PSIVRUN,WRD Q

NXT F ON=0:0 S ON=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON)) Q:'ON  S NOFLG=0 D SETP,PRNT:"DPN"'[P(17)

 Q

ENINIT ;

 F Z1=0:0 S Z1=$O(^PS(59.5,PSIVSN,2,Z1)) Q:'Z1  S Z2=^(Z1,0),PSIVT="" F PSIV1=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT=""  I $P(PSIVOD(PSIVT),".",2)=$P(+("."_Z2),".",2),(PSIVT=$P(Z2,"^",2)) S $P(^(0),"^",6)=PSIVOD(PSIVT)\1+("."_$P(^(0),"^"))

 S Z1="" F PSIV1=0:0 S Z1=$O(^PS(55,"PSIVWL",PSIVSN,Z1)) Q:Z1=""  S PSIVT="" F PSIV1=0:0 S PSIVT=$O(^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT)) Q:PSIVT=""  D K1

 K Z1,Z2 Q

K1 I $E(PSIVT,2,999)<(DT-1) K ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT) Q

 S Z2="" F PSIV1=0:0 S Z2=$O(PSIVOD(Z2)) Q:Z2=""  K:PSIVT=(Z2_PSIVOD(Z2)) ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSIVWL1   3813     printed  Feb 18, 2025@23:31:41                                                                                                                                                                                                     Page 2

PSIVWL1   ;BIR/RGY-WARD LIST ROUTINES ;02 AUG 96 / 9:40 AM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**81**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(55 is supported by DBIA 2191

 +4       ; Reference to ^VA(200 is supported by DBIA 10060

 +5       ;

SELMAN    ;

 +1        KILL PSM,PSIVMT,PSIVOD,PSIVCD

           SET PSCT=0

           FOR I=0:0

               SET I=$ORDER(^PS(59.5,PSIVSN,2,I))

               if 'I

                   QUIT 

               SET PSM(I)=^(I,0)

               SET PSCT=PSCT+1

P          WRITE !!?5,"The manufacturing times on file are:"

P0         FOR I=0:0

               SET I=$ORDER(PSM(I))

               if 'I

                   QUIT 

               SET X=PSM(I)

               WRITE !?10,I,"  ",$EXTRACT($PIECE(X,"^",5),1,2),":",$EXTRACT($PIECE(X,"^",5),3,4),"   ",$$CODES^PSIVUTL($PIECE(X,"^",2),59.51,.02)_" covering ",$PIECE(X,"^",3),"."

ASK       ;

 +1        SET X="Enter manufacturing time(s):^^^^QUX=+QUX!(QUX["","")!(QUX="""")"

           DO ENQ^PSIV

           if X["^"!(X="")

               QUIT 

           SET PSM=X

           FOR I=1:1

               SET X=$PIECE(PSM,",",I)

               if X=""

                   QUIT 

               IF '$DATA(PSM(X))

                   SET PSM="*"

                   QUIT 

 +2        IF PSM="*"

               SET HELP="ASKMAN"

               DO ^PSIVHLP

               GOTO P

SEL        FOR PSIV=1:1

               SET I=$PIECE(PSM,",",PSIV)

               if I=""

                   QUIT 

               SET PSIVMT($PIECE(PSM(I),"^",2))=+(PSIVDT_"."_$PIECE(PSM(I),"^",5))

               SET PSIVOD($PIECE(PSM(I),"^",2))=+(PSIVDT_"."_$PIECE(PSM(I),"^"))

               SET PSIVCD($PIECE(PSM(I),"^",2))=+(PSIVDT_"."_$PIECE(PSM(I),"^",4))

               DO SEL1

 +1        WRITE !

           SET X=PSM

           KILL PSM

           QUIT 

SEL1      ; INSTALL WITH V 17.3 OF FILEMAN

           IF $PIECE(PSM(I),"^")>$PIECE(PSM(I),"^",4)

               SET X1=PSIVDT

               SET X2=1

               DO C^%DTC

               SET X=$PIECE(X,".")

               SET $PIECE(PSIVCD($PIECE(PSM(I),"^",2)),".")=X

 +1        QUIT 

ENRSET     WRITE !

           SET X="Are you sure you want to RESET the Ward List (Y/N) ?^N"

           DO ENYN^PSIV

           if "N^"[$EXTRACT(X)

               QUIT 

           IF X="?"

               SET HELP="RESWL"

               DO ^PSIVHLP1

               GOTO ENRSET

 +1        DO SELMAN

           FOR I=1:1

               SET Y=$PIECE(X,",",I)

               if 'Y

                   QUIT 

               SET $PIECE(^PS(59.5,PSIVSN,2,Y,0),"^",6)=PSIVDT

               WRITE !,"... Ward list #",$PIECE(X,",",I)," reset"

 +2        QUIT 

PRNT      ;

 +1        if $Y+7>IOSL!(PSIVWARD'=WRD)

               DO HDR

           DO INP^VADPT

 +2        WRITE !,VAIN(5),?30

           SET PSIV=$ORDER(^PS(55,DFN,"IV",ON,"AD",0))

           if PSIV

               DO ENP2^PSIVRNL

           WRITE ?70

           SET Y=P(3)

           DO WD

           WRITE ?92,+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON),?100

           WRITE $PIECE($GET(^VA(200,+P(6),0)),U)

 +3        WRITE !,PSIV("NME")

           SET SSNF=0

           DO ENP3^PSIVRNL

           QUIT 

HDR        if $Y

               WRITE @IOF

           WRITE !,"WARD LIST FOR IV ROOM: ",$PIECE(^PS(59.5,PSIVSN,0),U)," AT "

           SET Y=PSIVDT

           XECUTE ^DD("DD")

           WRITE $PIECE(Y,"@"),?70,"Printed on   : "

           SET Y=PSIVRUN

           SET UWLTY=""

           XECUTE ^DD("DD")

           WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)

           WRITE !

 +1        FOR I=0:0

               SET UWLTY=$ORDER(PSIVOD(UWLTY))

               if UWLTY=""

                   QUIT 

               SET X=$$CODES^PSIVUTL(UWLTY,55.01,.04)

               WRITE !,X,"S",?15," covering from "

               SET Y=PSIVOD(UWLTY)

               DO WD

               WRITE " to "

               SET Y=PSIVCD(UWLTY)

               DO WD

               WRITE "  Manufacturing time: "

               SET Y=PSIVMT(UWLTY)

               DO WD

 +2        if NOFLG=1

               QUIT 

           WRITE !!?92,"Qty",!,"Patient name",?40,"Order",?70,"Stop date",?90,"needed",?100,"Provider/Initial"

 +3        WRITE !

           FOR X=1:1:110

               WRITE "-"

               if X=50

                   WRITE " Ward: ",WRD," "

 +4        SET PSIVWARD=WRD

 +5        KILL UWLTY

 +6        QUIT 

SETP       SET Y=^PS(55,DFN,"IV",ON,0)

           FOR X=1:1:23

               SET P(X)=$PIECE(Y,"^",X)

 +1        QUIT 

WD         XECUTE ^DD("DD")

           WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)

           QUIT 

CODES      SET X=$PIECE($PIECE(";"_$PIECE(Y,"^",3),";"_X_":",2),";")

           QUIT 

ENT       ;

 +1       ;Will print ward list

NOW        DO NOW^%DTC

           SET PSIVRUN=$EXTRACT(%,1,12)

           SET PSIVWARD=""

           KILL %,%I,%H

 +1        SET WRD=""

           SET NOFLG=1

           FOR JX=0:0

               SET WRD=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD))

               if WRD=""

                   QUIT 

               SET PSIVT=""

               FOR JX=0:0

                   SET PSIVT=$ORDER(PSIVOD(PSIVT))

                   if PSIVT=""

                       QUIT 

                   SET PSIVDT=PSIVOD(PSIVT)

                   DO NOW1

 +2        if NOFLG

               WRITE !!,"****NO DATA FOUND FOR THE WARD LIST WITH THE SELECTED IV TYPE(S)!****"

 +3        GOTO QPRNT

 +4        QUIT 

NOW1       FOR DFN=0:0

               SET DFN=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN))

               if 'DFN

                   QUIT 

               SET PSIV("NME")=$PIECE($GET(^DPT(DFN,0)),U)

               DO PID^VADPT

               DO NXT

 +1        QUIT 

QPRNT      KILL JX,PSIVT,PSIVWARD,PSIVDT,PSIVRUN,WRD

           QUIT 

NXT        FOR ON=0:0

               SET ON=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON))

               if 'ON

                   QUIT 

               SET NOFLG=0

               DO SETP

               if "DPN"'[P(17)

                   DO PRNT

 +1        QUIT 

ENINIT    ;

 +1        FOR Z1=0:0

               SET Z1=$ORDER(^PS(59.5,PSIVSN,2,Z1))

               if 'Z1

                   QUIT 

               SET Z2=^(Z1,0)

               SET PSIVT=""

               FOR PSIV1=0:0

                   SET PSIVT=$ORDER(PSIVOD(PSIVT))

                   if PSIVT=""

                       QUIT 

                   IF $PIECE(PSIVOD(PSIVT),".",2)=$PIECE(+("."_Z2),".",2)

                       IF (PSIVT=$PIECE(Z2,"^",2))

                           SET $PIECE(^(0),"^",6)=PSIVOD(PSIVT)\1+("."_$PIECE(^(0),"^"))

 +2        SET Z1=""

           FOR PSIV1=0:0

               SET Z1=$ORDER(^PS(55,"PSIVWL",PSIVSN,Z1))

               if Z1=""

                   QUIT 

               SET PSIVT=""

               FOR PSIV1=0:0

                   SET PSIVT=$ORDER(^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT))

                   if PSIVT=""

                       QUIT 

                   DO K1

 +3        KILL Z1,Z2

           QUIT 

K1         IF $EXTRACT(PSIVT,2,999)<(DT-1)

               KILL ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT)

               QUIT 

 +1        SET Z2=""

           FOR PSIV1=0:0

               SET Z2=$ORDER(PSIVOD(Z2))

               if Z2=""

                   QUIT 

               if PSIVT=(Z2_PSIVOD(Z2))

                   KILL ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT)

 +2        QUIT