PSIVORE ;BIR/PR,MLM-ORDER ENTRY ;29-May-2012 14:34;PLS
;;5.0; INPATIENT MEDICATIONS ;**18,29,50,56,58,81,1011,110,127,133,157,203,213,1015**;16 DEC 97;Build 62
;
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^ORX2 is supported by DBIA #867
; Reference to ^PSSLOCK is supported by DBIA #2789
; Reference to ^DICN is supported by DBIA 10009.
; Reference to ^DIR is supported by DBIA 10026.
; Reference to EN^VALM is supported by DBIA 10118.
; Reference to ^VADPT is supported by DBIA 10061.
;
; Modified - IHS/MSC/PLS - 03/28/2011 - Line SETN+1
N PSJNEW,PSJOUT,PSGPTMP,PPAGE,FLAG S PSJNEW=1
;
D SITE Q:'$G(PSIVQ) K PSIVQ S PSGOP=""
;
BEG ;Get patient and make sure he is living.
L +^PS(53.45,DUZ):1 E D LOCKERR^PSJOE G Q
;* F K WSCHADM S PSGPTMP=0,PPAGE=1 D ENGETP^PSIV Q:DFN<0 D ASK
;* F K WSCHADM S PSGPTMP=0,PPAGE=1 D ENGETP^PSIV Q:DFN<0 S X=DFN_";DPT(" D LK^ORX2 Q:'Y D ASK S X=DFN_";DPT(" D ULK^ORX2
NEW PSJLK
F K WSCHADM S PSGPTMP=0,PPAGE=1 D ENGETP^PSIV Q:DFN<0 S PSJLK='$$L^PSSLOCK(DFN,1) Q:PSJLK D ASK,UL^PSSLOCK(DFN)
I PSGOP,$P(PSJSYSL,"^",2)]"" D ENQL^PSGLW
G Q
;
ASK ;See if patient has been admitted.
I VADM(6) W !?5,"Patient has died." Q
I 'VAIN(4) K DIK S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO",DIR("??")="^S HELP=""ADMYN"" D ^PSIVHLP1" W !,"This patient has not been admitted." D ^DIR K DIR Q:'Y
S:VAIN(4) WSCHADM=+VAIN(4)
;
SETN ;Set up patient 0 node if needed.
D SETPTCX^APSPFUNC(DFN) ;IHS/MSC/PLS - 03/28/11
I '$D(^PS(55,DFN,0)) K DO,DA,DD,DIC,PSIVFN S:$D(^(5.1)) PSIVFN=^(5.1) K:$D(PSIVFN) ^(5.1) S (DINUM,X)=DFN,DIC(0)="L",DIC="^PS(55," D FILE^DICN S:$D(PSIVFN) ^PS(55,DFN,5.1)=PSIVFN D K DIC,PSIVFN,DO,DA,DD,DINUM
.; Mark PSJ and PSO as converted
.S $P(^PS(55,DFN,5.1),"^",11)=2
S PSJNARC=1
S PSGP=DFN,PSJPWD=+VAIN(4),PSIVAC="P",PSIVBR="D ^PSIVOPT" D HK,ENCHS1^PSIV Q:'$D(DFN)
Q
;
NEW ;Ask to enter new order.
D:'$D(VADM(1)) DEM^VADPT
K P,PSIVCHG,PSIVTYPE,PSJOE,DIR S DIR(0)="Y",DIR("A")="New order for "_VADM(1),DIR("B")="YES",DIR("??")="^S HELP=""NEWORD"" D ^PSIVHLP" D ^DIR K DIR Q:'Y
NEW X S X=DFN_";DPT(" D LK^ORX2 Q:'Y S PSJLSORX=1
INMED K ON55,PSJOUT S (P(4),P("OT"),P("FRES"))="" D NEW55^PSIVORFB I '$D(ON55) D ULK G:'$D(PSJOE)&('$D(PSJOUT)) NEW G Q
S P("RES")="N",PSIVAC="PN",P("PON")=ON55,PSIVUP=+$$GTPCI^PSIVUTL D NEW^PSIVORE2 I $G(P(2))="" D DEL55^PSIVORE2 D ULK G:'$D(PSJOE) NEW Q
D OK L -^PS(55,DFN,"IV",+ON55) D ULK G:'$D(PSJOE) NEW
;
Q ; Kill and exit.
L:'$D(PSJOE) -^PS(53.45,DUZ) S PSJNKF=1 D Q^PSIV
K FIL,I1,ND,PC,PDM,PSGDT,PSGID,PSGLMT,PSGSI,PSJNARC,PSIVAC,PSIVCHG,PSIVUP,PSIVX,PSJOPC
Q
;
ULK ;
Q:'$G(PSJLSORX) ;If NEW^PSIVORE did not lock, don't kill it here.
NEW X S X=DFN_";DPT(" D ULK^ORX2 K PSJLSORX
Q
HK ;Queue job to print MAR labels generated for this patient.
I PSGOP,PSGOP'=DFN D
.N PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR S DFN=PSGOP
.D INP^VADPT S PSJPWD=+VAIN(4) I PSJPWD S PSJACPF=10 S PSJACPF=10 D WP^PSJAC D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW
S PSGOP=DFN
Q
;
SITE ;See if site parameters are ok.
K PSIVQ D ^PSIVXU Q:$D(XQUIT)
I '$D(PSIVSN)!('$D(PSIVSITE)) W $C(7),$C(7),!!,"You have no IV ROOM parameters ... PLEASE ... PLEASE ...",!,"Exit this package and reenter properly !!",!! Q
D ORPARM^PSIVOREN S PSIVQ=1
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="^" G DOA
I ERR=1 S X="N" G BAD
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 IVs
D EFDIV^PSJUTL($G(ZZND))
W:$G(PSIVCHG) !,"*** This change will cause a new order to be created. ***"
I '$G(PSIVCOPY) G:PSIVAC["R" OK1 S X="Is this O.K.: ^"_$S(ERR:"NO",1:"YES")_"^^NO"_$S(ERR'=1:",YES",1:"") D ENQ^PSIV
S PSJIVBD=1 ;var use to indicate order enter from back door
BAD ;; I X["N" D GSTRING^PSIVORE1,^PSIVORV2,GTFLDS^PSIVORFE G OK
I ON55["V",($G(P(21))="") S P(17)="N"
I X["N" NEW PSGEBN,PSGLI S (P("INS"),PSGEBN,PSGLI)="",(PSJORD,ON)=ON55 D EN^VALM("PSJ LM IV AC/EDIT") S VALMBCK="Q" Q
I X["?" S HELP="OK" D ^PSIVHLP G OK
DOA I X["^" D DEL55^PSIVORE2 Q
Q:$$NONVF("SN")
OK1 S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))),P(17)="A",ORSTS=6,ON=ON55,PSJORNP=+P(6)
D:'$D(PSJIVORF) ORPARM^PSIVOREN
I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) D DEL55^PSIVORE2 Q
D SET55^PSIVORFB
I PSJIVORF,($G(P(22))=.5) D CLINIC^PSIVOREN
I PSJIVORF D SET^PSIVORFE S ORNATR=P("NAT"),ON=+ON55,OD=P(2) D EN1^PSJHL2(DFN,"SN",+ON55_"V","SEND ORDER NUMBER") ;,EN1^PSJHL2(DFN,"SC",+ON55_"V","NEW ORDER CREATED")
D VF1^PSJLIACT("V","ORDER ENTERED AS ACTIVE BY ",1)
D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"N")
;
CAL ;Calculate doses.
;S OD=P(2) D EN,^PSIVORE1,^PSIVOPT
S OD=P(2) D EN,^PSIVOPT
Q
;
EN ;Update schedule interval P(15) only on continuous orders.
;This includes Hyp/Adm/Continuous Syringes/Chemos =>P(5)=0
Q:'$D(DFN)!('$D(ON55)) Q:$P(^PS(55,DFN,"IV",+ON55,0),U,4)="P"!($P(^(0),U,5))!($P(^(0),U,23)="P")
D SPSOL S XXX=$P(^PS(55,DFN,"IV",+ON55,0),U,8) G:'SPSOL ENQ I XXX?1N.N.1".".N1" ml/hr"!(XXX?1"0."1N1" ml/hr") S P(15)=$S('XXX:0,1:SPSOL\XXX*60+(SPSOL#XXX/XXX*60+.5)\1),$P(^PS(55,DFN,"IV",+ON55,0),U,15)=P(15) G ENQ
S P(15)=$S('$P(XXX,"@",2):0,1:1440/$P(XXX,"@",2)\1),$P(^PS(55,DFN,"IV",+ON55,0),U,15)=P(15)
ENQ K SPSOL,XXX Q
SPSOL S SPSOL=0 F XXX=0:0 S XXX=$O(^PS(55,DFN,"IV",+ON55,"SOL",XXX)) Q:'XXX S SPSOL=SPSOL+$P(^(XXX,0),U,2)
K XXX Q
ENIN ;Entry for Combined IV/UD order entry. Called by PSJOE0.
D HOLDHDR^PSJOE
W !
N PSJOUT S (DONE,FLAG)=0,PSIVAC="PN"
ENIN1 ;
N DA,DIR,PSJOE,PSJPCAF,PSJSYSL,WSCHADM S:$G(VAIN(4)) WSCHADM=VAIN(4)
K P,PSIVCHG,PSJCOM
S PSJOE=1,DIR(0)="55.01,.04O",DIR("A")="Select IV TYPE" D ^DIR
I X]"",X'="^",$P("^PROFILE",X)="" S PSJOEPF=X Q
S:$D(DTOUT) X="^" I "^"[X S PSJORQF=PSJORQF+$S(X="^":2,$G(FLAG):0,1:1),X="." Q
S FLAG=1,PSIVTYPE=Y,(P(5),P(23))="" I "SC"[Y D @(Y_"^PSIVORC1") S $P(PSIVTYPE,U,2)=P(23)
D INMED G:'$D(PSJOUT) ENIN S:$D(PSJOUT) PSJORQF=2
Q
NONVF(PSJOC) ;If file at NonVF then quit with 1
NEW PSGOEAV S PSGOEAV=+$P(PSJSYSP0,U,9)
I +PSJSYSU=3,PSGOEAV Q 0
I +PSJSYSU=1,PSGOEAV Q 0
K DA D ENGNN^PSGOETO S ON=DA_"P",P(17)="N",P("REN")=0
D GTPD^PSIVORE2
D NATURE^PSIVOREN I '$D(P("NAT")) D:ON55["V" DEL55 Q 1
D:$G(VAIN(4))="" CLINIC^PSIVOREN
W !,"...transcribing this non-verified order...."
D PUT531^PSIVORFA
D:$G(PSJOC)]"" EN1^PSJHL2(DFN,PSJOC,ON,"SEND ORDER NUMBER")
D:ON55["V" DEL55
NEW PSJORD S (ON55,PSJORD)=ON
D VF^PSIVORC2
Q 1
DEL55 ;
Q:ON55["P"
S X=$G(^PS(55,DFN,"IV",+ON55,0))
I $P(X,U,21)]"",($G(^PS(55,DFN,"IV",+ON55,2))]"") S $P(^(2),U,6)=ON,$P(^PS(53.1,+ON,0),U,25)=ON55 Q
NEW PSIVORFA S PSIVORFA=1
D DEL55^PSIVORE2
Q
PSIVORE ;BIR/PR,MLM-ORDER ENTRY ;29-May-2012 14:34;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**18,29,50,56,58,81,1011,110,127,133,157,203,213,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to ^ORX2 is supported by DBIA #867
+5 ; Reference to ^PSSLOCK is supported by DBIA #2789
+6 ; Reference to ^DICN is supported by DBIA 10009.
+7 ; Reference to ^DIR is supported by DBIA 10026.
+8 ; Reference to EN^VALM is supported by DBIA 10118.
+9 ; Reference to ^VADPT is supported by DBIA 10061.
+10 ;
+11 ; Modified - IHS/MSC/PLS - 03/28/2011 - Line SETN+1
+12 NEW PSJNEW,PSJOUT,PSGPTMP,PPAGE,FLAG
SET PSJNEW=1
+13 ;
+14 DO SITE
IF '$GET(PSIVQ)
QUIT
KILL PSIVQ
SET PSGOP=""
+15 ;
BEG ;Get patient and make sure he is living.
+1 LOCK +^PS(53.45,DUZ):1
IF '$TEST
DO LOCKERR^PSJOE
GOTO Q
+2 ;* F K WSCHADM S PSGPTMP=0,PPAGE=1 D ENGETP^PSIV Q:DFN<0 D ASK
+3 ;* F K WSCHADM S PSGPTMP=0,PPAGE=1 D ENGETP^PSIV Q:DFN<0 S X=DFN_";DPT(" D LK^ORX2 Q:'Y D ASK S X=DFN_";DPT(" D ULK^ORX2
+4 NEW PSJLK
+5 FOR
KILL WSCHADM
SET PSGPTMP=0
SET PPAGE=1
DO ENGETP^PSIV
IF DFN<0
QUIT
SET PSJLK='$$L^PSSLOCK(DFN,1)
IF PSJLK
QUIT
DO ASK
DO UL^PSSLOCK(DFN)
+6 IF PSGOP
IF $PIECE(PSJSYSL,"^",2)]""
DO ENQL^PSGLW
+7 GOTO Q
+8 ;
ASK ;See if patient has been admitted.
+1 IF VADM(6)
WRITE !?5,"Patient has died."
QUIT
+2 IF 'VAIN(4)
KILL DIK
SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="NO"
SET DIR("??")="^S HELP=""ADMYN"" D ^PSIVHLP1"
WRITE !,"This patient has not been admitted."
DO ^DIR
KILL DIR
IF 'Y
QUIT
+3 IF VAIN(4)
SET WSCHADM=+VAIN(4)
+4 ;
SETN ;Set up patient 0 node if needed.
+1 ;IHS/MSC/PLS - 03/28/11
DO SETPTCX^APSPFUNC(DFN)
+2 IF '$DATA(^PS(55,DFN,0))
KILL DO,DA,DD,DIC,PSIVFN
IF $DATA(^(5.1))
SET PSIVFN=^(5.1)
IF $DATA(PSIVFN)
KILL ^(5.1)
SET (DINUM,X)=DFN
SET DIC(0)="L"
SET DIC="^PS(55,"
DO FILE^DICN
IF $DATA(PSIVFN)
SET ^PS(55,DFN,5.1)=PSIVFN
Begin DoDot:1
+3 ; Mark PSJ and PSO as converted
+4 SET $PIECE(^PS(55,DFN,5.1),"^",11)=2
End DoDot:1
KILL DIC,PSIVFN,DO,DA,DD,DINUM
+5 SET PSJNARC=1
+6 SET PSGP=DFN
SET PSJPWD=+VAIN(4)
SET PSIVAC="P"
SET PSIVBR="D ^PSIVOPT"
DO HK
DO ENCHS1^PSIV
IF '$DATA(DFN)
QUIT
+7 QUIT
+8 ;
NEW ;Ask to enter new order.
+1 IF '$DATA(VADM(1))
DO DEM^VADPT
+2 KILL P,PSIVCHG,PSIVTYPE,PSJOE,DIR
SET DIR(0)="Y"
SET DIR("A")="New order for "_VADM(1)
SET DIR("B")="YES"
SET DIR("??")="^S HELP=""NEWORD"" D ^PSIVHLP"
DO ^DIR
KILL DIR
IF 'Y
QUIT
+3 NEW X
SET X=DFN_";DPT("
DO LK^ORX2
IF 'Y
QUIT
SET PSJLSORX=1
INMED KILL ON55,PSJOUT
SET (P(4),P("OT"),P("FRES"))=""
DO NEW55^PSIVORFB
IF '$DATA(ON55)
DO ULK
IF '$DATA(PSJOE)&('$DATA(PSJOUT))
GOTO NEW
GOTO Q
+1 SET P("RES")="N"
SET PSIVAC="PN"
SET P("PON")=ON55
SET PSIVUP=+$$GTPCI^PSIVUTL
DO NEW^PSIVORE2
IF $GET(P(2))=""
DO DEL55^PSIVORE2
DO ULK
IF '$DATA(PSJOE)
GOTO NEW
QUIT
+2 DO OK
LOCK -^PS(55,DFN,"IV",+ON55)
DO ULK
IF '$DATA(PSJOE)
GOTO NEW
+3 ;
Q ; Kill and exit.
+1 IF '$DATA(PSJOE)
LOCK -^PS(53.45,DUZ)
SET PSJNKF=1
DO Q^PSIV
+2 KILL FIL,I1,ND,PC,PDM,PSGDT,PSGID,PSGLMT,PSGSI,PSJNARC,PSIVAC,PSIVCHG,PSIVUP,PSIVX,PSJOPC
+3 QUIT
+4 ;
ULK ;
+1 ;If NEW^PSIVORE did not lock, don't kill it here.
IF '$GET(PSJLSORX)
QUIT
+2 NEW X
SET X=DFN_";DPT("
DO ULK^ORX2
KILL PSJLSORX
+3 QUIT
HK ;Queue job to print MAR labels generated for this patient.
+1 IF PSGOP
IF PSGOP'=DFN
Begin DoDot:1
+2 NEW PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR
SET DFN=PSGOP
+3 DO INP^VADPT
SET PSJPWD=+VAIN(4)
IF PSJPWD
SET PSJACPF=10
SET PSJACPF=10
DO WP^PSJAC
IF $PIECE(PSJSYSL,U,2)]""
DO ENQL^PSGLW
End DoDot:1
+4 SET PSGOP=DFN
+5 QUIT
+6 ;
SITE ;See if site parameters are ok.
+1 KILL PSIVQ
DO ^PSIVXU
IF $DATA(XQUIT)
QUIT
+2 IF '$DATA(PSIVSN)!('$DATA(PSIVSITE))
WRITE $CHAR(7),$CHAR(7),!!,"You have no IV ROOM parameters ... PLEASE ... PLEASE ...",!,"Exit this package and reenter properly !!",!!
QUIT
+3 DO ORPARM^PSIVOREN
SET PSIVQ=1
+4 QUIT
+5 ;
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="^"
GOTO DOA
+3 IF ERR=1
SET X="N"
GOTO BAD
+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 IVs
+6 DO EFDIV^PSJUTL($GET(ZZND))
+7 IF $GET(PSIVCHG)
WRITE !,"*** This change will cause a new order to be created. ***"
+8 IF '$GET(PSIVCOPY)
IF PSIVAC["R"
GOTO OK1
SET X="Is this O.K.: ^"_$SELECT(ERR:"NO",1:"YES")_"^^NO"_$SELECT(ERR'=1:",YES",1:"")
DO ENQ^PSIV
+9 ;var use to indicate order enter from back door
SET PSJIVBD=1
BAD ;; I X["N" D GSTRING^PSIVORE1,^PSIVORV2,GTFLDS^PSIVORFE G OK
+1 IF ON55["V"
IF ($GET(P(21))="")
SET P(17)="N"
+2 IF X["N"
NEW PSGEBN,PSGLI
SET (P("INS"),PSGEBN,PSGLI)=""
SET (PSJORD,ON)=ON55
DO EN^VALM("PSJ LM IV AC/EDIT")
SET VALMBCK="Q"
QUIT
+3 IF X["?"
SET HELP="OK"
DO ^PSIVHLP
GOTO OK
DOA IF X["^"
DO DEL55^PSIVORE2
QUIT
+1 IF $$NONVF("SN")
QUIT
OK1 SET PSJORL=$$ENORL^PSJUTL($GET(VAIN(4)))
SET P(17)="A"
SET ORSTS=6
SET ON=ON55
SET PSJORNP=+P(6)
+1 IF '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
+2 IF PSJIVORF
DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
DO DEL55^PSIVORE2
QUIT
+3 DO SET55^PSIVORFB
+4 IF PSJIVORF
IF ($GET(P(22))=.5)
DO CLINIC^PSIVOREN
+5 ;,EN1^PSJHL2(DFN,"SC",+ON55_"V","NEW ORDER CREATED")
IF PSJIVORF
DO SET^PSIVORFE
SET ORNATR=P("NAT")
SET ON=+ON55
SET OD=P(2)
DO EN1^PSJHL2(DFN,"SN",+ON55_"V","SEND ORDER NUMBER")
+6 DO VF1^PSJLIACT("V","ORDER ENTERED AS ACTIVE BY ",1)
+7 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"N")
+8 ;
CAL ;Calculate doses.
+1 ;S OD=P(2) D EN,^PSIVORE1,^PSIVOPT
+2 SET OD=P(2)
DO EN
DO ^PSIVOPT
+3 QUIT
+4 ;
EN ;Update schedule interval P(15) only on continuous orders.
+1 ;This includes Hyp/Adm/Continuous Syringes/Chemos =>P(5)=0
+2 IF '$DATA(DFN)!('$DATA(ON55))
QUIT
IF $PIECE(^PS(55,DFN,"IV",+ON55,0),U,4)="P"!($PIECE(^(0),U,5))!($PIECE(^(0),U,23)="P")
QUIT
+3 DO SPSOL
SET XXX=$PIECE(^PS(55,DFN,"IV",+ON55,0),U,8)
IF 'SPSOL
GOTO ENQ
IF XXX?1N.N.1".".N1" ml/hr"!(XXX?1"0."1N1" ml/hr")
SET P(15)=$SELECT('XXX:0,1:SPSOL\XXX*60+(SPSOL#XXX/XXX*60+.5)\1)
SET $PIECE(^PS(55,DFN,"IV",+ON55,0),U,15)=P(15)
GOTO ENQ
+4 SET P(15)=$SELECT('$PIECE(XXX,"@",2):0,1:1440/$PIECE(XXX,"@",2)\1)
SET $PIECE(^PS(55,DFN,"IV",+ON55,0),U,15)=P(15)
ENQ KILL SPSOL,XXX
QUIT
SPSOL SET SPSOL=0
FOR XXX=0:0
SET XXX=$ORDER(^PS(55,DFN,"IV",+ON55,"SOL",XXX))
IF 'XXX
QUIT
SET SPSOL=SPSOL+$PIECE(^(XXX,0),U,2)
+1 KILL XXX
QUIT
ENIN ;Entry for Combined IV/UD order entry. Called by PSJOE0.
+1 DO HOLDHDR^PSJOE
+2 WRITE !
+3 NEW PSJOUT
SET (DONE,FLAG)=0
SET PSIVAC="PN"
ENIN1 ;
+1 NEW DA,DIR,PSJOE,PSJPCAF,PSJSYSL,WSCHADM
IF $GET(VAIN(4))
SET WSCHADM=VAIN(4)
+2 KILL P,PSIVCHG,PSJCOM
+3 SET PSJOE=1
SET DIR(0)="55.01,.04O"
SET DIR("A")="Select IV TYPE"
DO ^DIR
+4 IF X]""
IF X'="^"
IF $PIECE("^PROFILE",X)=""
SET PSJOEPF=X
QUIT
+5 IF $DATA(DTOUT)
SET X="^"
IF "^"[X
SET PSJORQF=PSJORQF+$SELECT(X="^":2,$GET(FLAG):0,1:1)
SET X="."
QUIT
+6 SET FLAG=1
SET PSIVTYPE=Y
SET (P(5),P(23))=""
IF "SC"[Y
DO @(Y_"^PSIVORC1")
SET $PIECE(PSIVTYPE,U,2)=P(23)
+7 DO INMED
IF '$DATA(PSJOUT)
GOTO ENIN
IF $DATA(PSJOUT)
SET PSJORQF=2
+8 QUIT
NONVF(PSJOC) ;If file at NonVF then quit with 1
+1 NEW PSGOEAV
SET PSGOEAV=+$PIECE(PSJSYSP0,U,9)
+2 IF +PSJSYSU=3
IF PSGOEAV
QUIT 0
+3 IF +PSJSYSU=1
IF PSGOEAV
QUIT 0
+4 KILL DA
DO ENGNN^PSGOETO
SET ON=DA_"P"
SET P(17)="N"
SET P("REN")=0
+5 DO GTPD^PSIVORE2
+6 DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
IF ON55["V"
DO DEL55
QUIT 1
+7 IF $GET(VAIN(4))=""
DO CLINIC^PSIVOREN
+8 WRITE !,"...transcribing this non-verified order...."
+9 DO PUT531^PSIVORFA
+10 IF $GET(PSJOC)]""
DO EN1^PSJHL2(DFN,PSJOC,ON,"SEND ORDER NUMBER")
+11 IF ON55["V"
DO DEL55
+12 NEW PSJORD
SET (ON55,PSJORD)=ON
+13 DO VF^PSIVORC2
+14 QUIT 1
DEL55 ;
+1 IF ON55["P"
QUIT
+2 SET X=$GET(^PS(55,DFN,"IV",+ON55,0))
+3 IF $PIECE(X,U,21)]""
IF ($GET(^PS(55,DFN,"IV",+ON55,2))]"")
SET $PIECE(^(2),U,6)=ON
SET $PIECE(^PS(53.1,+ON,0),U,25)=ON55
QUIT
+4 NEW PSIVORFA
SET PSIVORFA=1
+5 DO DEL55^PSIVORE2
+6 QUIT
