PSIVOPT2 ;BIR/PR,MLM-OPTION DRIVER (CONT) ;29-May-2012 14:34;PLS
;;5.0; INPATIENT MEDICATIONS ;**23,29,58,1009,1013,110,127,133,135,157,1015**;16 DEC 97;Build 62
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSSLOCK is supported by DBIA #2789
;
;Modified - IHS/MSC/PLS - 12/09/10 - Line R+3
; 10/16/11 - Line D+1
D ; Discontinue order.
N INCOM
S INCOM=$$INPTCOM^APSPFUNC()
I '$L(INCOM) W !,$C(7),"Order Unchanged." Q
D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." S COMQUIT=1 Q
;* 8/2* D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED"),D1
I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." S COMQUIT=1 Q
I 'PSJCOM D
.D D1
.S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55 D LOG^PSIVORAL S P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3)
I PSJCOM N COMFLG S COMFLG=0 D
.I ON55'["P" N COMFLG,O,OO S (COMFLG,O)=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" Q:COMFLG D
.. Q:OO=ON55 I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
I PSJCOM Q:COMFLG N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D
.I OO["V" S ON55=OO D D1 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55 D LOG^PSIVORAL N PSJORD S P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),PSJORD=ON55 D HL^PSIVORA Q
.I OO["U" N PSGORD,PSJORD,PSJNOO K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,PSGP=DFN,DA=+OO,DA(1)=PSGP,(PSGORD,PSJORD)=OO,PSJNOO=P("NAT") D
..S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ))) D ASET^PSGOEC,AC^PSGOEC
Q
D1 N %,DA,DIE,DIU,STP,NSTOP
S NSTOP=$$DATE^PSJUTL2(),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
K TMP
S TMP(55.01,""_+ON55_","_DFN_","_"",109)=NSTOP
S:'$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) TMP(55.01,""_+ON55_","_DFN_","_"",116)=STP
S TMP(55.01,""_+ON55_","_DFN_","_"",100)="D"
S TMP(55.01,""_+ON55_","_DFN_","_"",.03)=NSTOP
S PSIVACT=1
D FILE^DIE("","TMP")
K TMP
I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
Q
;
R ; Renew order.
;I PSJCOM D RIV^PSJCOMR Q
I PSJCOM D ^PSJCOMR Q
I P(17)="D",P(12) N ERR D RI W:$G(ERR)=1 $C(7)," Order unchanged." I $G(ERR)<2 S COMQUIT=1 Q
NEW PSGORQF S PSIVRNFG=1 D ORDCHK^PSJLIFN K PSIVRNFG W !
I $T(OI^APSPMULT)]"" N OI S OI=+$G(^PS(55,DFN,"IV",+PSJORD,.2)) I '$$OI^APSPMULT(OI) W $C(7),"Sorry, this drug is not currently available in this facility" Q ;IHS/MSC/JDS - 12/09/10 - MDF
I $G(PSGORQF) S COMQUIT=1 Q
;
R1 ;
I $$EXPIRED^PSGOER(DFN,ON55) D Q
.W !?3," THIS ORDER HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED ADMINISTRATIONS"
.W !?20," AND CANNOT BE RENEWED!"
N PSJRNWDT,PSJOSTOP,OREASON S PSJRNWDT=$$DATE2^PSJUTL2(PSGDT) S:$G(ON55) PSJOSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) I '(PSJOSTOP>P(2)),$G(PSGDT) S PSJOSTOP=PSGDT
S (PSIVOK,EDIT)="25^1" S P2=P(2),P(2)=PSJRNWDT D EDIT^PSIVEDT S P(2)=P2 K P2 I X="^" Q
S P(11)=$$ENRNAT^PSGOU($P($G(^PS(55,DFN,"IV",+ON55,2)),U,10),+VAIN(4),P(9),P(11))
D OK G:X["N" R1 I X=U D RD Q
S PSIVCHG=2
S P(17)="A",OREASON=P("RES"),P("RES")="R",P("FRES")="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D Q:'$D(P("NAT"))
.D NATURE^PSIVOREN I '$D(P("NAT")) D RD Q
.S ON=ON55
S P(16)="",PSJORIFN="",PSIVACT=1,P("21FLG")="",P("RES")=OREASON D SET55^PSIVORFB
D:$P(^PS(55,DFN,"IV",+ON55,0),U,17)="A" RUPDATE^PSIVOREN(DFN,ON55,P(2))
I PSJIVORF,$P(^PS(55,DFN,"IV",+ON55,0),U,17)'="A" S X=$$LS^PSSLOCK(DFN,+ON55_"V") D
.D EXPOE^PSGOER(DFN,ON55)
.S P("RES")="R",PSJREN=1
.D ENUDTX^PSJOREN(DFN,ON55,"NR"),EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED"),UPDREN(DFN,ON55,PSJRNWDT,P(6),PSJOSTOP,P("NAT"))
S OD=P(2)
D VF1^PSJLIACT("","",1),UNL^PSSLOCK(DFN,+ON55_"V")
D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
I $G(PSJOSTOP),$G(ON55),$G(DFN) D STIX^PSIVOREN(PSJOSTOP,ON55,DFN)
Q
;
RD ; Delete for renew.
;Q:'$G(PSJVFY)
;D DEL55^PSIVORE2 S (ON55,P("OLDON"))=P("PON") D GT55^PSIVORFB
Q
;
OK ;Print example label, run order through checker, ask if it is ok.
S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) I ($G(P("PD"))="") D GTPD^PSIVORE2
D ^PSIVCHK I $D(DUOUT) S X="^",COMQUIT=1 Q
I ERR=1 S X="N",COMQUIT=1 Q
W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
;PSJ*5*157 EFD FOR IV
D EFDIV^PSJUTL($G(ZZND))
I $G(PSIVCHG),($G(PSIVREA)'="R") W !,"*** This change will cause a new order to be created. ***"
S X="Is this O.K.: ^"_$S(ERR:"N",1:"Y")_"^^NO"_$S(ERR'=1:",YES",1:"") D ENQ^PSIV I X["?" S HELP="OK" D ^PSIVHLP G OK
Q
;
RI ; Reinstate Auto-DC'ed order.
N DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA W !!,$C(7),"This order has been Auto-DC'ed."
S DIR(0)="Y",DIR("A")="Reinstate this order" D ^DIR K DIR I 'Y S ERR=1 Q
D NOW^%DTC I %>$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) D
.K DIR S ERR=1,DIR(0)="Y",DIR("A",1)="The original stop date of this order has past.",DIR("A")="Do you wish to renew this order" D ^DIR K DIR S ERR=$S(Y:2,1:1)
Q:$G(ERR) S X=$G(^VA(200,+P(6),"PS")) I $S('X:1,'$P(X,U,4):0,DT<$P(X,U,4):0,1:1) S ERR=1
I $G(ERR) W !!,$C(7),"This order's provider is no longer valid. Please enter a valid provider." S (EDIT,PSIVOK)=1 D EDIT^PSIVEDT I $G(DONE) W $C(7),"Order unchanged." S ERR=1 Q
N PSGALO S PSGALO=18530 D ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
Q
;
UPDREN(DFN,ORD,RNWDT,PROV,OSTOPDT,PSJNOO) ;
Q:'DFN!'ORD!'RNWDT!'PROV!'OSTOPDT!(PSJNOO="")
K DR,DA,DIC,DIE,DD,DO N ND0,PSGOEORD
S DIC="^PS(55,"_DFN_",""IV"","_+ORD S ND0=$G(@(DIC_",0)")),PSGOEORD=$P(ND0,"^",21) I $G(ON)["P",$G(PSGOLDOE) S PSGOEORD=PSGOLDOE
S DIC=DIC_",14,",DIC(0)="L",DIC("P")="55.1138DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,DA(2)=DFN,DA(1)=+ORD D
.S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$G(DUZ)_";2////"_$G(PROV)_";3////"_$G(OSTOPDT)_";4////"_+PSGOEORD,X=$G(RNWDT) D FILE^DICN
.Q
K DO,DINUM
PSIVOPT2 ;BIR/PR,MLM-OPTION DRIVER (CONT) ;29-May-2012 14:34;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**23,29,58,1009,1013,110,127,133,135,157,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PSSLOCK is supported by DBIA #2789
+5 ;
+6 ;Modified - IHS/MSC/PLS - 12/09/10 - Line R+3
+7 ; 10/16/11 - Line D+1
D ; Discontinue order.
+1 NEW INCOM
+2 SET INCOM=$$INPTCOM^APSPFUNC()
+3 IF '$LENGTH(INCOM)
WRITE !,$CHAR(7),"Order Unchanged."
QUIT
+4 DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
WRITE !,$CHAR(7),"Order Unchanged."
SET COMQUIT=1
QUIT
+5 ;* 8/2* D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED"),D1
+6 IF '$$REQPROV^PSGOEC
WRITE !,$CHAR(7),"Order Unchanged."
SET COMQUIT=1
QUIT
+7 IF 'PSJCOM
Begin DoDot:1
+8 DO D1
+9 SET PSIVALT=1
SET PSIVALCK="STOP"
SET PSIVREA="D"
SET ON=ON55
DO LOG^PSIVORAL
SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
End DoDot:1
+10 IF PSJCOM
NEW COMFLG
SET COMFLG=0
Begin DoDot:1
+11 IF ON55'["P"
NEW COMFLG,O,OO
SET (COMFLG,O)=0
SET OO=""
FOR
SET O=$ORDER(^PS(55,"ACX",PSJCOM,O))
IF 'O
QUIT
FOR
SET OO=$ORDER(^PS(55,"ACX",PSJCOM,O,OO))
IF OO=""
QUIT
IF COMFLG
QUIT
Begin DoDot:2
+12 IF OO=ON55
QUIT
IF '$$LS^PSSLOCK(DFN,OO)
SET COMFLG=1
QUIT
End DoDot:2
End DoDot:1
+13 IF PSJCOM
IF COMFLG
QUIT
NEW O,OO
SET O=0
SET OO=""
FOR
SET O=$ORDER(^PS(55,"ACX",PSJCOM,O))
IF 'O
QUIT
FOR
SET OO=$ORDER(^PS(55,"ACX",PSJCOM,O,OO))
IF OO=""
QUIT
Begin DoDot:1
+14 IF OO["V"
SET ON55=OO
DO D1
SET PSIVALT=1
SET PSIVALCK="STOP"
SET PSIVREA="D"
SET ON=ON55
DO LOG^PSIVORAL
NEW PSJORD
SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
SET PSJORD=ON55
DO HL^PSIVORA
QUIT
+15 IF OO["U"
NEW PSGORD,PSJORD,PSJNOO
KILL DA
DO NOW^%DTC
SET PSGDT=%
SET T=$EXTRACT("T",'PSJSYSU)
SET PSGALR=20
SET PSGP=DFN
SET DA=+OO
SET DA(1)=PSGP
SET (PSGORD,PSJORD)=OO
SET PSJNOO=P("NAT")
Begin DoDot:2
+16 SET CF=$SELECT($PIECE(PSJSYSP0,U,5):1,PSGORD["U":0,1:($PIECE($GET(^PS(53.1,+PSGORD,0)),U,25)=""&($PIECE($GET(^(4)),U,7)=DUZ)))
DO ASET^PSGOEC
DO AC^PSGOEC
End DoDot:2
End DoDot:1
+17 QUIT
D1 NEW %,DA,DIE,DIU,STP,NSTOP
+1 SET NSTOP=$$DATE^PSJUTL2()
SET STP=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
SET NSTOP=+$SELECT(STP>NSTOP:NSTOP,1:STP)
SET P(17)="D"
+2 KILL TMP
+3 SET TMP(55.01,""_+ON55_","_DFN_","_"",109)=NSTOP
+4 IF '$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7)
SET TMP(55.01,""_+ON55_","_DFN_","_"",116)=STP
+5 SET TMP(55.01,""_+ON55_","_DFN_","_"",100)="D"
+6 SET TMP(55.01,""_+ON55_","_DFN_","_"",.03)=NSTOP
+7 SET PSIVACT=1
+8 DO FILE^DIE("","TMP")
+9 KILL TMP
+10 IF $SELECT($GET(PSIVAC)="OD":0,$GET(PSIVAC)'="AD":1,$GET(PSGALO)<1060:0,1:$PIECE($GET(PSJSYSW0),U,15))
SET X=$SELECT($GET(PSIVAC)="AD":1,1:2)
DO ENLBL^PSIVOPT(X,$SELECT(X=1:+$GET(PSGUOW),1:DUZ),DFN,3,+ON55,$EXTRACT("AD",1,3-X))
+11 ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
IF '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
IF 'PSJIVORF
QUIT
+12 QUIT
+13 ;
R ; Renew order.
+1 ;I PSJCOM D RIV^PSJCOMR Q
+2 IF PSJCOM
DO ^PSJCOMR
QUIT
+3 IF P(17)="D"
IF P(12)
NEW ERR
DO RI
IF $GET(ERR)=1
WRITE $CHAR(7)," Order unchanged."
IF $GET(ERR)<2
SET COMQUIT=1
QUIT
+4 NEW PSGORQF
SET PSIVRNFG=1
DO ORDCHK^PSJLIFN
KILL PSIVRNFG
WRITE !
+5 ;IHS/MSC/JDS - 12/09/10 - MDF
IF $TEXT(OI^APSPMULT)]""
NEW OI
SET OI=+$GET(^PS(55,DFN,"IV",+PSJORD,.2))
IF '$$OI^APSPMULT(OI)
WRITE $CHAR(7),"Sorry, this drug is not currently available in this facility"
QUIT
+6 IF $GET(PSGORQF)
SET COMQUIT=1
QUIT
+7 ;
R1 ;
+1 IF $$EXPIRED^PSGOER(DFN,ON55)
Begin DoDot:1
+2 WRITE !?3," THIS ORDER HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED ADMINISTRATIONS"
+3 WRITE !?20," AND CANNOT BE RENEWED!"
End DoDot:1
QUIT
+4 NEW PSJRNWDT,PSJOSTOP,OREASON
SET PSJRNWDT=$$DATE2^PSJUTL2(PSGDT)
IF $GET(ON55)
SET PSJOSTOP=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
IF '(PSJOSTOP>P(2))
IF $GET(PSGDT)
SET PSJOSTOP=PSGDT
+5 SET (PSIVOK,EDIT)="25^1"
SET P2=P(2)
SET P(2)=PSJRNWDT
DO EDIT^PSIVEDT
SET P(2)=P2
KILL P2
IF X="^"
QUIT
+6 SET P(11)=$$ENRNAT^PSGOU($PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,10),+VAIN(4),P(9),P(11))
+7 DO OK
IF X["N"
GOTO R1
IF X=U
DO RD
QUIT
+8 SET PSIVCHG=2
+9 SET P(17)="A"
SET OREASON=P("RES")
SET P("RES")="R"
SET P("FRES")=""
IF '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
IF PSJIVORF
Begin DoDot:1
+10 DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
DO RD
QUIT
+11 SET ON=ON55
End DoDot:1
IF '$DATA(P("NAT"))
QUIT
+12 SET P(16)=""
SET PSJORIFN=""
SET PSIVACT=1
SET P("21FLG")=""
SET P("RES")=OREASON
DO SET55^PSIVORFB
+13 IF $PIECE(^PS(55,DFN,"IV",+ON55,0),U,17)="A"
DO RUPDATE^PSIVOREN(DFN,ON55,P(2))
+14 IF PSJIVORF
IF $PIECE(^PS(55,DFN,"IV",+ON55,0),U,17)'="A"
SET X=$$LS^PSSLOCK(DFN,+ON55_"V")
Begin DoDot:1
+15 DO EXPOE^PSGOER(DFN,ON55)
+16 SET P("RES")="R"
SET PSJREN=1
+17 DO ENUDTX^PSJOREN(DFN,ON55,"NR")
DO EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED")
DO UPDREN(DFN,ON55,PSJRNWDT,P(6),PSJOSTOP,P("NAT"))
End DoDot:1
+18 SET OD=P(2)
+19 DO VF1^PSJLIACT("","",1)
DO UNL^PSSLOCK(DFN,+ON55_"V")
+20 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
+21 IF $GET(PSJOSTOP)
IF $GET(ON55)
IF $GET(DFN)
DO STIX^PSIVOREN(PSJOSTOP,ON55,DFN)
+22 QUIT
+23 ;
RD ; Delete for renew.
+1 ;Q:'$G(PSJVFY)
+2 ;D DEL55^PSIVORE2 S (ON55,P("OLDON"))=P("PON") D GT55^PSIVORFB
+3 QUIT
+4 ;
OK ;Print example label, run order through checker, ask if it is ok.
+1 SET P16=0
SET PSIVEXAM=1
SET (PSIVNOL,PSIVCT)=1
DO GTOT^PSIVUTL(P(4))
IF ($GET(P("PD"))="")
DO GTPD^PSIVORE2
+2 DO ^PSIVCHK
IF $DATA(DUOUT)
SET X="^"
SET COMQUIT=1
QUIT
+3 IF ERR=1
SET X="N"
SET COMQUIT=1
QUIT
+4 WRITE !
DO ^PSIVORLB
KILL PSIVEXAM
SET Y=P(2)
WRITE !,"Start date: "
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),?30," Stop date: "
SET Y=P(3)
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),!
+5 ;PSJ*5*157 EFD FOR IV
+6 DO EFDIV^PSJUTL($GET(ZZND))
+7 IF $GET(PSIVCHG)
IF ($GET(PSIVREA)'="R")
WRITE !,"*** This change will cause a new order to be created. ***"
+8 SET X="Is this O.K.: ^"_$SELECT(ERR:"N",1:"Y")_"^^NO"_$SELECT(ERR'=1:",YES",1:"")
DO ENQ^PSIV
IF X["?"
SET HELP="OK"
DO ^PSIVHLP
GOTO OK
+9 QUIT
+10 ;
RI ; Reinstate Auto-DC'ed order.
+1 NEW DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA
WRITE !!,$CHAR(7),"This order has been Auto-DC'ed."
+2 SET DIR(0)="Y"
SET DIR("A")="Reinstate this order"
DO ^DIR
KILL DIR
IF 'Y
SET ERR=1
QUIT
+3 DO NOW^%DTC
IF %>$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7)
Begin DoDot:1
+4 KILL DIR
SET ERR=1
SET DIR(0)="Y"
SET DIR("A",1)="The original stop date of this order has past."
SET DIR("A")="Do you wish to renew this order"
DO ^DIR
KILL DIR
SET ERR=$SELECT(Y:2,1:1)
End DoDot:1
+5 IF $GET(ERR)
QUIT
SET X=$GET(^VA(200,+P(6),"PS"))
IF $SELECT('X:1,'$PIECE(X,U,4):0,DT<$PIECE(X,U,4):0,1:1)
SET ERR=1
+6 IF $GET(ERR)
WRITE !!,$CHAR(7),"This order's provider is no longer valid. Please enter a valid provider."
SET (EDIT,PSIVOK)=1
DO EDIT^PSIVEDT
IF $GET(DONE)
WRITE $CHAR(7),"Order unchanged."
SET ERR=1
QUIT
+7 NEW PSGALO
SET PSGALO=18530
DO ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
+8 QUIT
+9 ;
UPDREN(DFN,ORD,RNWDT,PROV,OSTOPDT,PSJNOO) ;
+1 IF 'DFN!'ORD!'RNWDT!'PROV!'OSTOPDT!(PSJNOO="")
QUIT
+2 KILL DR,DA,DIC,DIE,DD,DO
NEW ND0,PSGOEORD
+3 SET DIC="^PS(55,"_DFN_",""IV"","_+ORD
SET ND0=$GET(@(DIC_",0)"))
SET PSGOEORD=$PIECE(ND0,"^",21)
IF $GET(ON)["P"
IF $GET(PSGOLDOE)
SET PSGOEORD=PSGOLDOE
+4 SET DIC=DIC_",14,"
SET DIC(0)="L"
SET DIC("P")="55.1138DA"
SET ND14=$GET(@(DIC_"0)"))
SET DINUM=$PIECE(ND14,"^",3)+1
SET DA(2)=DFN
SET DA(1)=+ORD
Begin DoDot:1
+5 SET DIC("DR")=".01////"_$GET(RNWDT)_";1////"_$GET(DUZ)_";2////"_$GET(PROV)_";3////"_$GET(OSTOPDT)_";4////"_+PSGOEORD
SET X=$GET(RNWDT)
DO FILE^DICN
+6 QUIT
End DoDot:1
+7 KILL DO,DINUM
