Routine: PSIVORC

PSIVORC ;BIR/MLM-COMPLETE IV ORDERS ENTERED THROUGH OE/RR ;29-May-2012 14:34;PLS

 ;;5.0; INPATIENT MEDICATIONS ;**23,53,80,1013,110,134,1015**;16 DEC 97;Build 62

 ; Reference to ^DIC(42 is supported by DBIA 10039

 ; Reference to ^DPT is supported by DBIA 10035

 ; Reference to ^%DTC is supported by DBIA 10000

 ; Reference to ^DID is supported by DBIA 2052

 ; Modified - IHS/MSC/PLS - 10/16/2011 - DISCONT+1

EN ; Set IV parameters.

 D SITE^PSIVORE Q:'$G(PSIVQ)  K PSIVQ

SELECT ;

 F  S PSGSSH="ORVC" D ^PSGSEL Q:U[PSGSS  D GTORDRS

 D DONE^PSIVORC1

GTORDRS ;

 K ^TMP("PSIV",$J) N DIC,Y D @PSGSS Q:+$G(Y)'>0  W:PSGSS'="P" !,"...a few moments, please..." D @("G"_PSGSS)

 I $G(Y),'$D(^TMP("PSIV",$J)) W !,$C(7),"NO PENDING ORDERS FOR ",$S(PSGSS="P":"PATIENT",1:"WARD"),$S(PSGSS="G":" GROUP",1:"")," SELECTED." Q

 D NOW^%DTC S HDT=$$ENDTC^PSGMI(%),PSIVAC="C",DONE=0,WDN=""

 F  S WDN=$O(^TMP("PSIV",$J,WDN)) Q:WDN=""!DONE  S PNME="" F  S PNME=$O(^TMP("PSIV",$J,WDN,PNME)) Q:PNME=""!DONE  D

 . I PSGSS'="P" S PSGDFN=$P(PNME,";",2)_"^"_$P(PNME,";") D CHK^PSJDPT(.PSGDFN,1,1) I PSGDFN=-1 Q

 . D PROFILE D:PSIVHD ASK

 D:$G(PSIVHD) ASK

PROFILE ; Display profile of all incomplete orders.

 K PSGODDD S (DFN,PSGP)=$P(PNME,";",2) D ENBOTH^PSJAC

 S RB=PSJPRB,PG=1,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))),PSJIVOF=PSJORL,PSGLMT=0,LN2="" D ENHEAD^PSJO3

 S (DONE1,TYP)="" F  S TYP=$O(^TMP("PSIV",$J,WDN,PNME,TYP)) Q:TYP=""!(DONE1)  D:$Y+5'>IOSL GTYP F ON1=0:0 S ON1=$O(^TMP("PSIV",$J,WDN,PNME,TYP,ON1)) Q:'ON1!(DONE1)  D DISPLAY

DISPLAY ; Display order on profile.

 I $Y+5>IOSL D ASK Q:DONE1  D ENHEAD^PSJO3,GTYP

 S PSIVHD=1,PSGLMT=PSGLMT+1,PSIVCV(PSGLMT)=ON1,PSJC="" W !?3,PSGLMT D PIV^PSIVUTL(+ON1_"P")

GTYP ; Get formatted heading for type

 N PSJD5314 D FIELD^DID(53.1,4,"","POINTER","PSJD5314")

 ; removed ^DD ref 3-2-99, pass ^^_set of codes value

 ; because codes^psivutl uses the 3rd piece

 S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER"),"")

 S PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X

ASK ; Ask which orders to view.

 S PSIVHD=0,ACTION="ORDER" D RD1^PSGON I X="^" S (DONE,DONE1)=1 Q

 Q:'$D(PSGODDD)  S DONE1=0 F PN=1:1:$L(PSGODDD(1),",")-1 S ON=+$P(PSGODDD(1),",",PN) Q:ON=""!DONE1  S ON=+$P(PSGODDD(1),",",PN) D SHOW

 S DONE1=1,PSGOP=DFN D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW

SHOW ; Display selected order and prompt for action

 S (P("PON"),ON)=PSIVCV(ON)

SHOW1 ; Entry point from backdoor.

 S PSIVUP=+$$GTPCI^PSIVUTL D GT531^PSIVORFA(DFN,ON) I $G(PSIVAC)="PRO" D ENNONUM^PSIVORV2(DFN,ON) Q

 I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)

 S PSJORD=+ON D ^PSJLIFN

 ; look-ups on ward group, ward, or patient; depending on value of SS

G S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC S:+Y>0 WG=+Y Q

W S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC S:+Y>0 WD=+Y Q

P D ENGETP^PSIV Q:DFN<0  S Y=1 I $D(^PS(53.1,"AS","P",+DFN)) S PNME=$G(^DPT(+DFN,0)),PNME=$P(PNME,U)_";"_DFN,WDN=$S(VAIN(4)]"":$P(VAIN(4),U,2),1:"OUTPATIENT") D GP

GG ; put patient(s) with incomplete orders into array

 F WD=0:0 S WD=$O(^PS(57.5,"AC",WG,WD)) Q:'WD  D GW

GW S WDN=$G(^DIC(42,WD,0)),WDN=$P(WDN,U) I WDN]"" F DFN=0:0 S DFN=$O(^DPT("CN",WDN,DFN)) Q:'DFN  I $D(^PS(53.1,"AS","P",DFN)) S Y=$G(^DPT(+DFN,0)),PNME=$P(Y,U)_";"_DFN D:PNME]"" GP

GP ;

 F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON  S Y=$G(^PS(53.1,ON,0)),TYP=$S($P(Y,U,4)]"":$P(Y,U,4),1:"Z"),^TMP("PSIV",$J,WDN,PNME,TYP,ON)=""

DISCONT ; Cancel incomplete order

 N PSJDCTYP I $G(ON)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(ON) I $G(PSJDCTYP)'=1 D PNDRN(PSJDCTYP) Q

 N INCOM

D2 ; Called from PNDRN for pending order

 D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF S INCOM=$$INPTCOM^APSPFUNC() D NATURE^PSIVOREN I '$D(P("NAT"))!(INCOM="") W !,$C(7),"Order Unchanged." Q

 ;Prompt for requesting provider

 W ! I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." K PSJDCTYP Q

W !

D3 ; called from PNDRN for original order

 I 'PSJCOM N PSJORNAT S PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED")

 I PSJCOM,PSJORD["P" N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  D

 .S ON=O_"P",PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA

 W !,"Order discontinued.",!

EDIT ; Edit incomplete order

 S PSIVAC="CE" L +^PS(53.1,+ON):1 E  W !,$C(7),"This order LOCKED by another user." Q

 D EDIT^PSIVORC2 L -^PS(53.1,+ON)

FINISH ; Finish incomplete order

 S PSIVAC="CF" L +^PS(53.1,+ON):1 E  W !,$C(7),"This order LOCKED by another user." Q

 D FINISH^PSIVORC2 L -^PS(53.1,+ON)

PNDRN(PSJDCTYP) ; Discontinue pending renewal only or both pending and original orders

 I PSJDCTYP=2 S PSJDCTYP=1 D D2 Q:'$G(PSJDCTYP)  D

 .N ND5310 S ND5310=$G(^PS(53.1,+ON,0))

 .N ON S ON=$P(ND5310,"^",25) I ON S PSJDCTYP=2 D D3

PSIVORC   ;BIR/MLM-COMPLETE IV ORDERS ENTERED THROUGH OE/RR ;29-May-2012 14:34;PLS

 +1       ;;5.0; INPATIENT MEDICATIONS ;**23,53,80,1013,110,134,1015**;16 DEC 97;Build 62

 +2       ;

 +3       ; Reference to ^DIC(42 is supported by DBIA 10039

 +4       ; Reference to ^DPT is supported by DBIA 10035

 +5       ; Reference to ^%DTC is supported by DBIA 10000

 +6       ; Reference to ^DID is supported by DBIA 2052

 +7       ;

 +8       ; Modified - IHS/MSC/PLS - 10/16/2011 - DISCONT+1

EN        ; Set IV parameters.

 +1        DO SITE^PSIVORE

           IF '$GET(PSIVQ)

               QUIT

           KILL PSIVQ

 +2       ;

SELECT    ;

 +1        FOR

               SET PSGSSH="ORVC"

               DO ^PSGSEL

               IF U[PSGSS

                   QUIT

               DO GTORDRS

 +2        DO DONE^PSIVORC1

 +3        QUIT

GTORDRS   ;

 +1        KILL ^TMP("PSIV",$JOB)

           NEW DIC,Y

           DO @PSGSS

           IF +$GET(Y)'>0

               QUIT

           IF PSGSS'="P"

               WRITE !,"...a few moments, please..."

           DO @("G"_PSGSS)

 +2        IF $GET(Y)

               IF '$DATA(^TMP("PSIV",$JOB))

                   WRITE !,$CHAR(7),"NO PENDING ORDERS FOR ",$SELECT(PSGSS="P":"PATIENT",1:"WARD"),$SELECT(PSGSS="G":" GROUP",1:"")," SELECTED."

                   QUIT

 +3        DO NOW^%DTC

           SET HDT=$$ENDTC^PSGMI(%)

           SET PSIVAC="C"

           SET DONE=0

           SET WDN=""

 +4        FOR

               SET WDN=$ORDER(^TMP("PSIV",$JOB,WDN))

               IF WDN=""!DONE

                   QUIT

               SET PNME=""

FOR

                   SET PNME=$ORDER(^TMP("PSIV",$JOB,WDN,PNME))

                   IF PNME=""!DONE

                       QUIT

                   Begin DoDot:1

 +5                    IF PSGSS'="P"

                           SET PSGDFN=$PIECE(PNME,";",2)_"^"_$PIECE(PNME,";")

                           DO CHK^PSJDPT(.PSGDFN,1,1)

                           IF PSGDFN=-1

                               QUIT

 +6                    DO PROFILE

                       IF PSIVHD

                           DO ASK

                   End DoDot:1

 +7        IF $GET(PSIVHD)

               DO ASK

 +8        QUIT

 +9       ;

PROFILE   ; Display profile of all incomplete orders.

 +1       ;

 +2        KILL PSGODDD

           SET (DFN,PSGP)=$PIECE(PNME,";",2)

           DO ENBOTH^PSJAC

 +3        SET RB=PSJPRB

           SET PG=1

           SET PSJORL=$$ENORL^PSJUTL($GET(VAIN(4)))

           SET PSJIVOF=PSJORL

           SET PSGLMT=0

           SET LN2=""

           DO ENHEAD^PSJO3

 +4        SET (DONE1,TYP)=""

FOR

               SET TYP=$ORDER(^TMP("PSIV",$JOB,WDN,PNME,TYP))

               IF TYP=""!(DONE1)

                   QUIT

               IF $Y+5'>IOSL

                   DO GTYP

               FOR ON1=0:0

                   SET ON1=$ORDER(^TMP("PSIV",$JOB,WDN,PNME,TYP,ON1))

                   IF 'ON1!(DONE1)

                       QUIT

                   DO DISPLAY

 +5        QUIT

 +6       ;

DISPLAY   ; Display order on profile.

 +1        IF $Y+5>IOSL

               DO ASK

               IF DONE1

                   QUIT

               DO ENHEAD^PSJO3

               DO GTYP

 +2        SET PSIVHD=1

           SET PSGLMT=PSGLMT+1

           SET PSIVCV(PSGLMT)=ON1

           SET PSJC=""

           WRITE !?3,PSGLMT

           DO PIV^PSIVUTL(+ON1_"P")

 +3        QUIT

 +4       ;

GTYP      ; Get formatted heading for type

 +1        NEW PSJD5314

           DO FIELD^DID(53.1,4,"","POINTER","PSJD5314")

 +2       ; removed ^DD ref 3-2-99, pass ^^_set of codes value

 +3       ; because codes^psivutl uses the 3rd piece

 +4        SET X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER"),"")

 +5        SET PSIV=$SELECT(X]"":X,1:"UNKNOWN")

           SET X=""

           SET $PIECE(X,"-",40-($LENGTH(PSIV)/2))=""

           WRITE !,X_PSIV_X

 +6        QUIT

 +7       ;

ASK       ; Ask which orders to view.

 +1        SET PSIVHD=0

           SET ACTION="ORDER"

           DO RD1^PSGON

           IF X="^"

               SET (DONE,DONE1)=1

               QUIT

 +2        IF '$DATA(PSGODDD)

               QUIT

           SET DONE1=0

           FOR PN=1:1:$LENGTH(PSGODDD(1),",")-1

               SET ON=+$PIECE(PSGODDD(1),",",PN)

               IF ON=""!DONE1

                   QUIT

               SET ON=+$PIECE(PSGODDD(1),",",PN)

               DO SHOW

 +3        SET DONE1=1

           SET PSGOP=DFN

           IF $PIECE(PSJSYSL,U,2)]""

               DO ENQL^PSGLW

 +4        QUIT

 +5       ;

SHOW      ; Display selected order and prompt for action

 +1        SET (P("PON"),ON)=PSIVCV(ON)

 +2       ;

SHOW1     ; Entry point from backdoor.

 +1        SET PSIVUP=+$$GTPCI^PSIVUTL

           DO GT531^PSIVORFA(DFN,ON)

           IF $GET(PSIVAC)="PRO"

               DO ENNONUM^PSIVORV2(DFN,ON)

               QUIT

 +2        IF $GET(PSJORD)["P"

               DO REQDT^PSJLIVMD(PSJORD)

 +3        SET PSJORD=+ON

           DO ^PSJLIFN

 +4        QUIT

 +5       ;

 +6       ; look-ups on ward group, ward, or patient; depending on value of SS

G          SET DIC="^PS(57.5,"

           SET DIC(0)="QEAMI"

           SET DIC("A")="Select WARD GROUP: "

           WRITE !

           DO ^DIC

           IF +Y>0

               SET WG=+Y

           QUIT

W          SET DIC="^DIC(42,"

           SET DIC(0)="QEAMI"

           SET DIC("A")="Select WARD: "

           WRITE !

           DO ^DIC

           IF +Y>0

               SET WD=+Y

           QUIT

P          DO ENGETP^PSIV

           IF DFN<0

               QUIT

           SET Y=1

           IF $DATA(^PS(53.1,"AS","P",+DFN))

               SET PNME=$GET(^DPT(+DFN,0))

               SET PNME=$PIECE(PNME,U)_";"_DFN

               SET WDN=$SELECT(VAIN(4)]"":$PIECE(VAIN(4),U,2),1:"OUTPATIENT")

               DO GP

 +1        QUIT

 +2       ;

GG        ; put patient(s) with incomplete orders into array

 +1        FOR WD=0:0

               SET WD=$ORDER(^PS(57.5,"AC",WG,WD))

               IF 'WD

                   QUIT

               DO GW

 +2        QUIT

GW         SET WDN=$GET(^DIC(42,WD,0))

           SET WDN=$PIECE(WDN,U)

           IF WDN]""

               FOR DFN=0:0

                   SET DFN=$ORDER(^DPT("CN",WDN,DFN))

                   IF 'DFN

                       QUIT

                   IF $DATA(^PS(53.1,"AS","P",DFN))

                       SET Y=$GET(^DPT(+DFN,0))

                       SET PNME=$PIECE(Y,U)_";"_DFN

                       IF PNME]""

                           DO GP

 +1        QUIT

GP        ;

 +1        FOR ON=0:0

               SET ON=$ORDER(^PS(53.1,"AS","P",DFN,ON))

               IF 'ON

                   QUIT

               SET Y=$GET(^PS(53.1,ON,0))

               SET TYP=$SELECT($PIECE(Y,U,4)]"":$PIECE(Y,U,4),1:"Z")

               SET ^TMP("PSIV",$JOB,WDN,PNME,TYP,ON)=""

 +2        QUIT

DISCONT   ; Cancel incomplete order

 +1        NEW PSJDCTYP

           IF $GET(ON)["P"

               IF $PIECE($GET(^PS(53.1,+$GET(ON),0)),"^",24)="R"

                   SET PSJDCTYP=$$PNDRNA^PSGOEC(ON)

                   IF $GET(PSJDCTYP)'=1

                       DO PNDRN(PSJDCTYP)

                       QUIT

 +2        NEW INCOM

D2        ; Called from PNDRN for pending order

 +1        IF '$DATA(PSJIVORF)

               DO ORPARM^PSIVOREN

           IF PSJIVORF

               SET INCOM=$$INPTCOM^APSPFUNC()

               DO NATURE^PSIVOREN

               IF '$DATA(P("NAT"))!(INCOM="")

                   WRITE !,$CHAR(7),"Order Unchanged."

                   QUIT

 +2       ;Prompt for requesting provider

 +3        WRITE !

           IF '$$REQPROV^PSGOEC

               WRITE !,$CHAR(7),"Order Unchanged."

               KILL PSJDCTYP

               QUIT

 +4        WRITE !

 +5       ;

D3        ; called from PNDRN for original order

 +1       ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED")

           IF 'PSJCOM

               NEW PSJORNAT

               SET PSJORIFN=$PIECE($GET(^PS(53.1,+ON,0)),U,21)

               SET PSJORD=ON

               SET PSJORNAT=P("NAT")

               DO DC^PSIVORA

 +2        IF PSJCOM

               IF PSJORD["P"

                   NEW O

                   SET O=""

FOR

                       SET O=$ORDER(^PS(53.1,"ACX",PSJCOM,O))

                       IF O=""

                           QUIT

                       Begin DoDot:1

 +3                        SET ON=O_"P"

                           SET PSJORIFN=$PIECE($GET(^PS(53.1,+ON,0)),U,21)

                           SET PSJORD=ON

                           SET PSJORNAT=P("NAT")

                           DO DC^PSIVORA

                       End DoDot:1

 +4        WRITE !,"Order discontinued.",!

 +5        QUIT

 +6       ;

EDIT      ; Edit incomplete order

 +1        SET PSIVAC="CE"

           LOCK +^PS(53.1,+ON):1

          IF '$TEST

               WRITE !,$CHAR(7),"This order LOCKED by another user."

               QUIT

 +2        DO EDIT^PSIVORC2

           LOCK -^PS(53.1,+ON)

 +3        QUIT

 +4       ;

FINISH    ; Finish incomplete order

 +1        SET PSIVAC="CF"

           LOCK +^PS(53.1,+ON):1

          IF '$TEST

               WRITE !,$CHAR(7),"This order LOCKED by another user."

               QUIT

 +2        DO FINISH^PSIVORC2

           LOCK -^PS(53.1,+ON)

 +3        QUIT

 +4       ;

PNDRN(PSJDCTYP) ; Discontinue pending renewal only or both pending and original orders

 +1        IF PSJDCTYP=2

               SET PSJDCTYP=1

               DO D2

               IF '$GET(PSJDCTYP)

                   QUIT

               Begin DoDot:1

 +2                NEW ND5310

                   SET ND5310=$GET(^PS(53.1,+ON,0))

 +3                NEW ON

                   SET ON=$PIECE(ND5310,"^",25)

                   IF ON

                       SET PSJDCTYP=2

                       DO D3

               End DoDot:1

 +4        QUIT

PSIVORC.m