PSONEW.m

PSONEW ;BIR/SAB-new rx order main driver ;05-Jun-2013 15:42;DU

 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,1013,268,225,1015,1017**;DEC 1997;Build 40

 ;External references L and UL^PSSLOCK supported by DBIA 2789

 ;External reference to ^VA(200 supported by DBIA 224

 ;External reference to ^XUSEC supported by DBIA 10076

 ;External reference to ^ORX1 supported by DBIA 2186

 ;External reference to ^ORX2 supported by DBIA 867

 ;External reference to ^TIUEDIT supported by DBIA 2410

 ;---------------------------------------------------------------

 ; Modified - IHS/CIA/PLS - 01/02/04 - Line AGAIN+10 and COUN+2

 ;            IHS/MSC/PLS - 09/21/11 - Line DIR+2

 ;                          10/28/11 - Line AGAIN+10

 ;                          06/05/13 - Line DIR+4

OERR ;backdoor new rx for v7

 K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET

 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q

 K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q

AGAIN N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN") W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"))=0,PSOFROM="NEW",PSONOEDT=1

 K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry

 I PSONEW("QFLG") G END

 I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END

 D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN

 I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END

 D NOOR I PSONEW("DFLG") D DEL G END

 D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct

 G:$G(PSORX("FN")) END

 D EN^PSON52(.PSONEW) ; Files entry in File 52

 D EN^APSPPCC1(PSODFN,PSONEW("IRXN"))  ;P1013 - prompt for POV

 I $G(APSP("CM"))]"" S $P(^PSRX(PSONEW("IRXN"),9999999),"^",2)=APSP("CM")   ; IHS/CIA/PLS - 01/02/04 Set chronic med

 I $D(P(99)) S $P(^PSRX(PSONEW("IRXN"),9999999),"^")=+P(99)   ; IHS/CIA/PLS - 01/02/04 Set Expiration Date

 D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array

 S VALMBCK="R"

END D EOJ ; Clean up

 I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN

 D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN)

 D RV^PSOORFL

 S VALMBCK="R" K PSORX("FN") Q

 ;----------------------------------------------------------------

DEL ;

 W !,$C(7),"RX DELETED",!

 I $P($G(PSOPAR),"^",7)=1 D

 . S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#",""))

 . S PSOX=PSONEW("OLD LAST RX#",PSOY)

 . L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)

 . S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)

 . D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y

 . L -^PS(59,+PSOSITE,PSOY)

 . K PSOX,PSOY Q

EOJ ;

 I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN

 K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT")

 D CLEAN^PSOVER1

 K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC

 S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D

 .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))

 .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")

 K RXN,RXN1,^TMP("PSORXN",$J)

 I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)

 K PSONOTE

 Q

NOOR ;asks nature of order

 N PSONOODF

 S PSONOODF=0

 I $G(OR0) D  G NOORX ;front door

 .S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0) I 'PSOI S PSONOOR="" D:$D(^XUSEC("PSORPH",DUZ)) COUN Q  ;NoO $P(OR0,"^",7)

 .S PSONOODF=1

 .D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q

 .S PSONOOR=Y D:$D(^XUSEC("PSORPH",DUZ)) COUN K DIR,DTOUT,DTOUT,DIRUT

 ;backdoor order

 D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q

 S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT

 G:'$D(^XUSEC("PSORPH",DUZ)) NOORX

COUN ;patient counseling

 G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT

 ; IHS/CIA/PLS - 01/15/04/ - Skip Counsel prompt if IHS

 I $G(DUZ("AG"))="I" S PSOCOU="",PSOCOUU=0 G PRONTE

 S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0)

 I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q

 K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0)

PRONTE K PSONOTE,DIR,DIRUT,DUOUT

 I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D  K DIR,DIRUT,DUOUT

 .S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR

 .S PSONOTE=+Y Q  ;I 'Y!($D(DIRUT)) Q

NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT

 Q

DIR ;ask nature of order

 K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]""  D  Q

 .;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))   ;IHS/MSC/PLS - 09/21/11 Commented out line

 .;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))  ;IHS/MSC/PLS - 09/21/11

 .S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIV"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))  ;IHS/MSC/PLS - 06/05/13

 .I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q

 .S DIRUT=1 K PSONOOR

 I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")

 K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN")

 S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")

 D ^DIR K DF,PSONODF Q:$D(DIRUT)  S PSONOOR=Y

DIRX Q

 ;

NOORE(PSONEW) ;entry point for renew

 D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q

 S PSONEW("NOO")=PSONOOR

 Q

PSONEW    ;BIR/SAB-new rx order main driver ;05-Jun-2013 15:42;DU

 +1       ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,1013,268,225,1015,1017**;DEC 1997;Build 40

 +2       ;External references L and UL^PSSLOCK supported by DBIA 2789

 +3       ;External reference to ^VA(200 supported by DBIA 224

 +4       ;External reference to ^XUSEC supported by DBIA 10076

 +5       ;External reference to ^ORX1 supported by DBIA 2186

 +6       ;External reference to ^ORX2 supported by DBIA 867

 +7       ;External reference to ^TIUEDIT supported by DBIA 2410

 +8       ;---------------------------------------------------------------

 +9       ; Modified - IHS/CIA/PLS - 01/02/04 - Line AGAIN+10 and COUN+2

 +10      ;            IHS/MSC/PLS - 09/21/11 - Line DIR+2

 +11      ;                          10/28/11 - Line AGAIN+10

 +12      ;                          06/05/13 - Line DIR+4

OERR      ;backdoor new rx for v7

 +1        KILL PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET

 +2        SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)

           IF '$GET(PSOPLCK)

               DO LOCK^PSOORCPY

               SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")

               KILL PSOPLCK

               SET VALMBCK=""

               QUIT 

 +3        KILL PSOPLCK

           SET X=PSODFN_";DPT("

           DO LK^ORX2

           IF 'Y

               SET VALMSG="Another person is entering orders for this patient."

               SET VALMBCK=""

               DO UL^PSSLOCK(PSODFN)

               QUIT 

AGAIN      NEW VALMCNT

           KILL PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN")

           WRITE !

           DO HLDHDR^PSOLMUTL

           SET (PSONEW("QFLG"),PSONEW("DFLG"))=0

           SET PSOFROM="NEW"

           SET PSONOEDT=1

 +1       ; Continue order entry

           KILL ORD

           DO FULL^VALM1

           DO ^PSONEW1

 +2        IF PSONEW("QFLG")

               GOTO END

 +3        IF PSONEW("DFLG")

               WRITE !,$CHAR(7),"RX DELETED",!

               IF $GET(POERR)

                   SET POERR("DFLG")=1

                   SET VALMBCK="Q"

               GOTO END

 +4        IF $PIECE($GET(PSOPAR),"^",7)=1

               DO AUTO^PSONRXN

           IF $PIECE($GET(PSOPAR),"^",7)'=1

               SET PSOX=PSONEW("RX #")

               DO CHECK^PSONRXN

 +5        IF PSONEW("DFLG")!PSONEW("QFLG")

               DO DEL

               IF $GET(POERR)

                   SET POERR("DFLG")=1

                   SET VALMBCK="R"

               GOTO END

 +6        DO NOOR

           IF PSONEW("DFLG")

               DO DEL

               GOTO END

 +7       ; Asks if correct

           DO ^PSONEW2

           IF PSONEW("DFLG")

               DO DEL

               IF $GET(POERR)

                   SET POERR("DFLG")=1

                   SET VALMBCK="R"

               GOTO END

 +8        IF $GET(PSORX("FN"))

               GOTO END

 +9       ; Files entry in File 52

           DO EN^PSON52(.PSONEW)

 +10      ;P1013 - prompt for POV

           DO EN^APSPPCC1(PSODFN,PSONEW("IRXN"))

 +11      ; IHS/CIA/PLS - 01/02/04 Set chronic med

           IF $GET(APSP("CM"))]""

               SET $PIECE(^PSRX(PSONEW("IRXN"),9999999),"^",2)=APSP("CM")

 +12      ; IHS/CIA/PLS - 01/02/04 Set Expiration Date

           IF $DATA(P(99))

               SET $PIECE(^PSRX(PSONEW("IRXN"),9999999),"^")=+P(99)

 +13      ; Adds newly added rx to PSOSD array

           DO NPSOSD^PSOUTIL(.PSONEW)

 +14       SET VALMBCK="R"

END       ; Clean up

           DO EOJ

 +1        IF '$GET(PSORX("FN"))

               WRITE !

               KILL DIR,DIRUT,DUOUT,DTOUT

               SET DIR(0)="Y"

               SET DIR("B")="YES"

               SET DIR("A")="Another New Order for "_PSORX("NAME")

               DO ^DIR

               KILL DIR,DIRUT,DUOUT,DTOUT

               IF Y

                   KILL PSONEW,PSDRUG,ORD

                   GOTO AGAIN

 +2        DO ^PSOBUILD

           DO BLD^PSOORUT1

           SET X=PSODFN_";DPT("

           DO ULK^ORX2

           DO UL^PSSLOCK(PSODFN)

 +3        DO RV^PSOORFL

 +4        SET VALMBCK="R"

           KILL PSORX("FN")

           QUIT 

 +5       ;----------------------------------------------------------------

DEL       ;

 +1        WRITE !,$CHAR(7),"RX DELETED",!

 +2        IF $PIECE($GET(PSOPAR),"^",7)=1

               Begin DoDot:1

 +3                SET DIE="^PS(59,"

                   SET DA=PSOSITE

                   SET PSOY=$ORDER(PSONEW("OLD LAST RX#",""))

 +4                SET PSOX=PSONEW("OLD LAST RX#",PSOY)

 +5                LOCK +^PS(59,+PSOSITE,PSOY):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)

 +6                SET DR=$SELECT(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)

 +7                IF PSOX<$PIECE(^PS(59,+PSOSITE,PSOY),"^",3)

                       DO ^DIE

                   KILL DIE,X,Y

 +8                LOCK -^PS(59,+PSOSITE,PSOY)

 +9                KILL PSOX,PSOY

                   QUIT 

               End DoDot:1

EOJ       ;

 +1       ; +Lock set in PSONRXN

           IF $DATA(PSONEW("RX #"))

               LOCK -^PSRX("B",PSONEW("RX #"))

 +2        KILL PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT")

 +3        DO CLEAN^PSOVER1

 +4        KILL ^TMP("PSORXDC",$JOB),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC

 +5        SET RXN=$ORDER(^TMP("PSORXN",$JOB,0))

           IF RXN

               Begin DoDot:1

 +6                SET RXN1=^TMP("PSORXN",$JOB,RXN)

                   DO EN^PSOHLSN1(RXN,$PIECE(RXN1,"^"),$PIECE(RXN1,"^",2),"",$PIECE(RXN1,"^",3))

 +7                IF $PIECE(^PSRX(RXN,"STA"),"^")=5

                       DO EN^PSOHLSN1(RXN,"SC","ZS","")

               End DoDot:1

 +8        KILL RXN,RXN1,^TMP("PSORXN",$JOB)

 +9        IF $GET(PSONOTE)

               DO FULL^VALM1

               DO MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)

 +10       KILL PSONOTE

 +11       QUIT 

NOOR      ;asks nature of order

 +1        NEW PSONOODF

 +2        SET PSONOODF=0

 +3       ;front door

           IF $GET(OR0)

               Begin DoDot:1

 +4       ;NoO $P(OR0,"^",7)

                   SET PSOI=$SELECT($GET(PSOSIGFL):1,$GET(PSODRUG("OI"))'=$PIECE(OR0,"^",8):1,1:0)

                   IF 'PSOI

                       SET PSONOOR=""

                       IF $DATA(^XUSEC("PSORPH",DUZ))

                           DO COUN

                       QUIT 

 +5                SET PSONOODF=1

 +6                DO DIR

                   IF $DATA(DIRUT)

                       SET PSONEW("DFLG")=1

                       QUIT 

 +7                SET PSONOOR=Y

                   IF $DATA(^XUSEC("PSORPH",DUZ))

                       DO COUN

                   KILL DIR,DTOUT,DTOUT,DIRUT

               End DoDot:1

               GOTO NOORX

 +8       ;backdoor order

 +9        DO DIR

           IF $DATA(DIRUT)

               SET PSONEW("DFLG")=1

               QUIT 

 +10       SET PSONOOR=Y

           KILL DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT

 +11       IF '$DATA(^XUSEC("PSORPH",DUZ))

               GOTO NOORX

COUN      ;patient counseling

 +1        IF $GET(PSORX("EDIT"))&('$GET(PSOSIGFL))

               GOTO NOORX

           KILL DIR,DUOUT,DTOUT,DIRUT

 +2       ; IHS/CIA/PLS - 01/15/04/ - Skip Counsel prompt if IHS

 +3        IF $GET(DUZ("AG"))="I"

               SET PSOCOU=""

               SET PSOCOUU=0

               GOTO PRONTE

 +4        SET DIR("B")="NO"

           SET DIR(0)="52,41"

           DO ^DIR

           SET PSOCOU=$SELECT(Y:Y,1:0)

 +5        IF $DATA(DIRUT)!('PSOCOU)

               SET PSOCOUU=0

               IF '$GET(SPEED)

                   DO PRONTE

               QUIT 

 +6        IF '$GET(PSOCOU)

               KILL PSOCOUU

           KILL DIR,DUOUT,DTOUT,DIRUT

           IF Y

               SET DIR(0)="52,42"

               SET DIR("B")="NO"

               DO ^DIR

               SET PSOCOUU=$SELECT(Y:Y,1:0)

PRONTE     KILL PSONOTE,DIR,DIRUT,DUOUT

 +1        IF $TEXT(MAIN^TIUEDIT)]""

               IF '$GET(SPEED)

                   Begin DoDot:1

 +2                    SET DIR(0)="Y"

                       SET DIR("B")="No"

                       SET DIR("A")="Do you want to enter a Progress Note"

                       SET DIR("A",1)=""

                       DO ^DIR

                       KILL DIR

 +3       ;I 'Y!($D(DIRUT)) Q

                       SET PSONOTE=+Y

                       QUIT 

                   End DoDot:1

                   KILL DIR,DIRUT,DUOUT

NOORX      KILL X,Y,DIR,DUOUT,DTOUT,DIRUT

 +1        QUIT 

DIR       ;ask nature of order

 +1        KILL DIR,DTOUT,DTOUT,DIRUT

           IF $TEXT(NA^ORX1)]""

               Begin DoDot:1

 +2       ;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))   ;IHS/MSC/PLS - 09/21/11 Commented out line

 +3       ;S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))  ;IHS/MSC/PLS - 09/21/11

 +4       ;IHS/MSC/PLS - 06/05/13

                   SET PSONOOR=$$NA^ORX1($SELECT($GET(PSONOODF)!($GET(PSONOBCK)):"S",1:$$GET1^DIQ(100.02,$$GET1^DIQ(9009033,PSOSITE,407,"I"),.02)),0,"B","Nature of Order",0,"WPSDIV"_$SELECT(+$GET(^VA(200,DUZ,"PS")):"E",1:""))

 +5                IF +PSONOOR

                       SET (Y,PSONOOR)=$PIECE(PSONOOR,"^",3)

                       QUIT 

 +6                SET DIRUT=1

                   KILL PSONOOR

               End DoDot:1

               QUIT 

 +7        IF $DATA(PSONOOR)

               SET DF=PSONOOR

               SET PSONODF=$SELECT(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")

 +8        KILL DIR,DTOUT,DTOUT,DIRUT

           SET DIR("A")="Nature of Order: "

           SET DIR("B")=$SELECT($DATA(PSONOOR):PSONODF,1:"WRITTEN")

 +9        SET DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$SELECT(+$GET(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")

 +10       DO ^DIR

           KILL DF,PSONODF

           IF $DATA(DIRUT)

               QUIT 

           SET PSONOOR=Y

DIRX       QUIT 

 +1       ;

NOORE(PSONEW) ;entry point for renew

 +1        DO NOOR

           IF $DATA(DIRUT)

               SET PSONEW("DFLG")=1

               QUIT 

 +2        SET PSONEW("NOO")=PSONOOR

 +3        QUIT