PSONEW ;BIR/SAB - new rx order main driver ;Jul 24, 2017@15:24
;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,225,251,379,390,417,313,411,457,524,711,545,700,753**;DEC 1997;Build 53
;External reference to UL^PSSLOCK supported by DBIA 2789
;External reference to $$L^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
;External reference to ^DD("DILOCKTM" supported by DBIA 999
;---------------------------------------------------------------
OERR ;backdoor new rx for v7
K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET,PSOTITRX,PSOMTFLG,QUIT N PSOCKCON,PSODAOC
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"),PSORX("DFLG"),PSOQUIT,POERR S PSORX("DFLG")=0
N PSOHZ,PSOLSTDR,OR0 S (PSOHZ,PSOLSTDR)=0 ;*524;*711
W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"),PSOQUIT)=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 NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
S VALMBCK="R"
;
; - Possible Titration prescription
I $G(PSONEW("IRXN")) D MARK^PSOOTMRX(PSONEW("IRXN"),0)
;
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<$$GET1^DIQ(59,+PSOSITE,+DR,"I") ^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"),ZNEW,PSOMAILX
D CLEAN^PSOVER1
K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC,PSORX("RXDEA"),PSORX("DETX") ;*545
S (ZRXN,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 $$GET1^DIQ(52,RXN,100,"I")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
.;; START NCC REMEDIATION >> 457*MZR
.N PSOCLOZO S PSOCLOZO=($$GET1^DIQ(50,+$$GET1^DIQ(52,RXN,6,"I"),17.5)="PSOCLO1") ; Clozapine order
.I PSOCLOZO,$G(PSOLOGDT) N ORN S ORN=$$GET1^DIQ(52,RXN,39.3,"I") I ORN D ;/MZR populate ^XTMP entry with order #
..I $P($G(^XTMP("YSCLTRN",DT,DFN,PSOLOGDT,0)),"^",3)=RXN D ORDSET^YSCLTST6(ORN)
.;; END NCC REMEDIATION >> 457*457
.;saves drug allergy order chks pso*7*390
.I $D(^TMP("PSODAOC",$J)) D
..S RXN=ZRXN,PSODAOC="Rx Backdoor "_$S($$GET1^DIQ(52,RXN,100,"I")=4:"NON-VERIFIED ",1:"")_"NEW Order Acceptance_OP",ZNEW=1
.D DAOC
K ZRXN,RXN,RXN1,^TMP("PSORXN",$J),^TMP("PSODAOC",$J),RET,PSODAOC,ZNEW
I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
K PSONOTE,PSOCKCON,ZZCOPY
;W !! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT
Q
NOOR ;asks nature of order
N PSONOODF
S PSONOODF=0
;; START NCC REMEDIATION >> 457*MZR
;/MZR Added a next line because otherwise data gets lost
I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1",'$D(PSONEW("SAND")),$G(PSOSAND) S PSONEW("SAND")=PSOSAND K PSOSAND
;; EMD NCC REMEDIATION >> 457*MZR
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:$$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH") COUN Q ;NoO $P(OR0,"^",7)
.S PSONOODF=1
.D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
.S PSONOOR=Y D:$$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH") COUN K DIR,DTOUT,DTOUT,DIRUT
;backdoor order
D DIR I $D(DIRUT) S PSONEW("DFLG")=1,VALMBCK="Q" Q
S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
G:'$D(^XUSEC("PSORPH",DUZ)) NOORX
COUN ;patient counseling
S PSOMAILX=$G(PSONEW("MAIL EXEMPTION")) ;mail exemption p743
G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
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($$GET1^DIQ(200,DUZ,53.3):"E",1:""))
.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($$GET1^DIQ(200,DUZ,53.3):";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
DAOC ;adds all backdoor order checks to file 100.05.
D ^PSONEWOC K ^TMP("PSODAOC",$J),PSRDI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONEW 7038 printed Oct 16, 2024@18:32 Page 2
PSONEW ;BIR/SAB - new rx order main driver ;Jul 24, 2017@15:24
+1 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,225,251,379,390,417,313,411,457,524,711,545,700,753**;DEC 1997;Build 53
+2 ;External reference to UL^PSSLOCK supported by DBIA 2789
+3 ;External reference to $$L^PSSLOCK supported by DBIA 2789
+4 ;External reference to ^VA(200 supported by DBIA 224
+5 ;External reference to ^XUSEC( supported by DBIA 10076
+6 ;External reference to ^ORX1 supported by DBIA 2186
+7 ;External reference to ^ORX2 supported by DBIA 867
+8 ;External reference to ^TIUEDIT supported by DBIA 2410
+9 ;External reference to ^DD("DILOCKTM" supported by DBIA 999
+10 ;---------------------------------------------------------------
OERR ;backdoor new rx for v7
+1 KILL PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET,PSOTITRX,PSOMTFLG,QUIT
NEW PSOCKCON,PSODAOC
+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"),PSORX("DFLG"),PSOQUIT,POERR
SET PSORX("DFLG")=0
+1 ;*524;*711
NEW PSOHZ,PSOLSTDR,OR0
SET (PSOHZ,PSOLSTDR)=0
+2 WRITE !
DO HLDHDR^PSOLMUTL
SET (PSONEW("QFLG"),PSONEW("DFLG"),PSOQUIT)=0
SET PSOFROM="NEW"
SET PSONOEDT=1
+3 ; Continue order entry
KILL ORD
DO FULL^VALM1
DO ^PSONEW1
+4 IF PSONEW("QFLG")
GOTO END
+5 IF PSONEW("DFLG")
WRITE !,$CHAR(7),"RX DELETED",!
if $GET(POERR)
SET POERR("DFLG")=1
SET VALMBCK="Q"
GOTO END
+6 if $PIECE($GET(PSOPAR),"^",7)=1
DO AUTO^PSONRXN
IF $PIECE($GET(PSOPAR),"^",7)'=1
SET PSOX=PSONEW("RX #")
DO CHECK^PSONRXN
+7 IF PSONEW("DFLG")!PSONEW("QFLG")
DO DEL
if $GET(POERR)
SET POERR("DFLG")=1
SET VALMBCK="R"
GOTO END
+8 DO NOOR
IF PSONEW("DFLG")
DO DEL
GOTO END
+9 ; Asks if correct
DO ^PSONEW2
IF PSONEW("DFLG")
DO DEL
if $GET(POERR)
SET POERR("DFLG")=1
SET VALMBCK="R"
GOTO END
+10 if $GET(PSORX("FN"))
GOTO END
+11 ; Files entry in File 52
DO EN^PSON52(.PSONEW)
+12 ; Adds newly added rx to PSOSD array
DO NPSOSD^PSOUTIL(.PSONEW)
+13 SET VALMBCK="R"
+14 ;
+15 ; - Possible Titration prescription
+16 IF $GET(PSONEW("IRXN"))
DO MARK^PSOOTMRX(PSONEW("IRXN"),0)
+17 ;
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<$$GET1^DIQ(59,+PSOSITE,+DR,"I")
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"),ZNEW,PSOMAILX
+3 DO CLEAN^PSOVER1
+4 ;*545
KILL ^TMP("PSORXDC",$JOB),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC,PSORX("RXDEA"),PSORX("DETX")
+5 SET (ZRXN,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 $$GET1^DIQ(52,RXN,100,"I")=5
DO EN^PSOHLSN1(RXN,"SC","ZS","")
+8 ;; START NCC REMEDIATION >> 457*MZR
+9 ; Clozapine order
NEW PSOCLOZO
SET PSOCLOZO=($$GET1^DIQ(50,+$$GET1^DIQ(52,RXN,6,"I"),17.5)="PSOCLO1")
+10 ;/MZR populate ^XTMP entry with order #
IF PSOCLOZO
IF $GET(PSOLOGDT)
NEW ORN
SET ORN=$$GET1^DIQ(52,RXN,39.3,"I")
IF ORN
Begin DoDot:2
+11 IF $PIECE($GET(^XTMP("YSCLTRN",DT,DFN,PSOLOGDT,0)),"^",3)=RXN
DO ORDSET^YSCLTST6(ORN)
End DoDot:2
+12 ;; END NCC REMEDIATION >> 457*457
+13 ;saves drug allergy order chks pso*7*390
+14 IF $DATA(^TMP("PSODAOC",$JOB))
Begin DoDot:2
+15 SET RXN=ZRXN
SET PSODAOC="Rx Backdoor "_$SELECT($$GET1^DIQ(52,RXN,100,"I")=4:"NON-VERIFIED ",1:"")_"NEW Order Acceptance_OP"
SET ZNEW=1
End DoDot:2
+16 DO DAOC
End DoDot:1
+17 KILL ZRXN,RXN,RXN1,^TMP("PSORXN",$JOB),^TMP("PSODAOC",$JOB),RET,PSODAOC,ZNEW
+18 IF $GET(PSONOTE)
DO FULL^VALM1
DO MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
+19 KILL PSONOTE,PSOCKCON,ZZCOPY
+20 ;W !! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT
+21 QUIT
NOOR ;asks nature of order
+1 NEW PSONOODF
+2 SET PSONOODF=0
+3 ;; START NCC REMEDIATION >> 457*MZR
+4 ;/MZR Added a next line because otherwise data gets lost
+5 IF $$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)="PSOCLO1"
IF '$DATA(PSONEW("SAND"))
IF $GET(PSOSAND)
SET PSONEW("SAND")=PSOSAND
KILL PSOSAND
+6 ;; EMD NCC REMEDIATION >> 457*MZR
+7 ;front door
IF $GET(OR0)
Begin DoDot:1
+8 SET PSOI=$SELECT($GET(PSOSIGFL):1,$GET(PSODRUG("OI"))'=$PIECE(OR0,"^",8):1,1:0)
+9 ;NoO $P(OR0,"^",7)
IF 'PSOI
SET PSONOOR=""
if $$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH")
DO COUN
QUIT
+10 SET PSONOODF=1
+11 DO DIR
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
QUIT
+12 SET PSONOOR=Y
if $$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH")
DO COUN
KILL DIR,DTOUT,DTOUT,DIRUT
End DoDot:1
GOTO NOORX
+13 ;backdoor order
+14 DO DIR
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
SET VALMBCK="Q"
QUIT
+15 SET PSONOOR=Y
KILL DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
+16 if '$DATA(^XUSEC("PSORPH",DUZ))
GOTO NOORX
COUN ;patient counseling
+1 ;mail exemption p743
SET PSOMAILX=$GET(PSONEW("MAIL EXEMPTION"))
+2 if $GET(PSORX("EDIT"))&('$GET(PSOSIGFL))
GOTO NOORX
KILL DIR,DUOUT,DTOUT,DIRUT
+3 SET DIR("B")="NO"
SET DIR(0)="52,41"
DO ^DIR
SET PSOCOU=$SELECT(Y:Y,1:0)
+4 IF $DATA(DIRUT)!('PSOCOU)
SET PSOCOUU=0
if '$GET(SPEED)
DO PRONTE
QUIT
+5 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 SET PSONOOR=$$NA^ORX1($SELECT($GET(PSONOODF)!($GET(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$SELECT($$GET1^DIQ(200,DUZ,53.3):"E",1:""))
+3 IF +PSONOOR
SET (Y,PSONOOR)=$PIECE(PSONOOR,"^",3)
QUIT
+4 SET DIRUT=1
KILL PSONOOR
End DoDot:1
QUIT
+5 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")
+6 KILL DIR,DTOUT,DTOUT,DIRUT
SET DIR("A")="Nature of Order: "
SET DIR("B")=$SELECT($DATA(PSONOOR):PSONODF,1:"WRITTEN")
+7 SET DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$SELECT($$GET1^DIQ(200,DUZ,53.3):";E:PROVIDER ENTERED",1:"")
+8 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
DAOC ;adds all backdoor order checks to file 100.05.
+1 DO ^PSONEWOC
KILL ^TMP("PSODAOC",$JOB),PSRDI
+2 QUIT
