PSIVORFE ;BIR/MLM-IV FLUID ORDER ENTRY FOR OE/RR FRONT DOOR. ;26 NOV 97 / 9:55 AM
;;5.0;INPATIENT MEDICATIONS ;**58,81,110,258**;16 DEC 97;Build 3
;
; Reference to ^VA(200 is supported by DBIA 10060.
;
EN ; Entry pt. to create new IV Fluid order.
S PSJORNP=$G(ORNP) D PS^PSIVOREN Q:PSJORPF F D NEWORD Q:DONE
D DONE^PSIVORA1
Q
;
NEWORD ; Create new IV Fluid order.
D SETUP S EDIT=58,PSIVOK="" D EDIT^PSIVEDT I '$D(DRG("SOL")) S DONE=1 Q
; Removed reference to tag 66 of PSIVEDT-backdoor Pharm Prov comments
S EDIT="57^59",PSIVOK=58 D EDIT^PSIVEDT Q:DONE
K DA,DIC,ON,P("OLDON") W !!,"...transcribing this order..." D ENGNN^PSGOETO S ON=DA D PUT531^PSIVORFA L -^PS(53.1,+ON) W !
Q
;
GTFLDS ;Ask field no.s to be edited.
N PSGEFN F X=1:1:$L(EDIT,U) S PSGEFN(X)=$P(EDIT,U,X)_U_$S($P(EDIT,U,X)=999:"Edit OE/RR Fields",1:$$CODES2^PSIVUTL(53.1,$P(EDIT,U,X)))
S Y=$P($G(XQORNOD(0)),"=",2)
S PSGEFN=1_":"_$L(EDIT,U),PSJDTYP=$E(PSIVAC,1) D:Y="" ENEFA^PSGON K PSJDTYP I '$G(Y) S:PSIVAC="OE" DONE=1 Q
S X=EDIT,EDIT="" F X1=1:1:$L(Y,",") S:$P(X,U,$P(Y,",",X1)) $P(EDIT,"^",X1)=$P(X,U,$P(Y,",",X1))
N PSIVRENW S PSIVRENW=1
D EDIT^PSIVEDT
K PSIVRENW
Q
;
SET ; Set variables needed to create/update orders in the ORDERS file (100).
Q
;*** NO LONGER NEEDED IN 5.0
N DRGT,PLN,X K OREVENT,ORETURN,ORSTRT,ORSTOP,ORTX
S ORL=$$ENORL^PSJUTL($G(VAIN(4)))
S ORLOG=P("LOG"),ORSTRT=P(2),OREVENT=$S('P(3):"",1:P(3)_";E"),ORSTOP=P(3),ORNP=+P(6),P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I")
D GTOT^PSIVUTL(P(4)) ;* S ORPCL=$P(P("OT"),U,2)
;* S Y=P(17),ORSTS=$S("AO"[Y:6,Y="E":7,Y="H":3,Y="D":1,Y="U":11,1:5),ORVP=DFN_";DPT(",ORPK=+ON_$S(ORSTS=5:"P",ORSTS=11:"P",1:"V")
SORTX ;Set up ORTX(.
Q
;*** NO LONGER NEEDED IN 5.0
I $E(P("OT"))="H" D
.S ORTX(1)="* TPN * in ",PLN=2 F X=0:0 S X=$O(DRG("SOL",X)) Q:'X S ORTX(PLN)=$S($P($G(DRG("SOL",X)),U,2)]"":$P(DRG("SOL",X),U,2),1:"*NF*"),PLN=PLN+1
.S ORTX(PLN)=$S(P(8)]"":P(8),1:P(9)),PLN=PLN+1
I $E(P("OT"))="F" D ORTXF
I $E(P("OT"))="I" S ORTX(1)=$P(P("PD"),U,2),ORTX(2)="Give: "_$P(P("MR"),U,2)_" "_$S(P(9)]"":P(9),1:P(8)),PLN=3
S ORTX(1)=$S($G(P("FRES"))="R":"RENEWED -",$G(P("RES"))="R":"RENEWAL -",1:"")_ORTX(1)
;I $D(^PS(53.45,+$G(PSIVUP),4)) F PC=0:0 S PC=$O(^PS(53.45,PSIVUP,4,PC)) Q:'PC S ORTX(PLN)=$G(^PS(53.45,PSIVUP,4,PC,0)),PLN=PLN+1
Q
;
ORTXF ; Set up ORTX( for Fluids.
Q
;*** NO LONGER NEEDED IN 5.0
N SOLF
S PLN=1 F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI D
.S ORTX(PLN)=$S($P(DRG(DRGT,DRGI),U,2)="":"*NF*",1:$P(DRG(DRGT,DRGI),U,2)_" "_$P(DRG(DRGT,DRGI),U,3)),PLN=PLN+1 I DRGT="SOL",('$G(SOLF)) S ORTX(PLN-1)="in "_ORTX(PLN-1),SOLF=1
S ORTX(PLN)=$S(P(8)]"":P(8),1:P(9)),PLN=PLN+1
Q
;
SETUP ; Initialize variables.
K DRG D NEWENT S DRGN="" F X=2,3,5,7,8,9,11,15,23,"AD","DO","IVRM","MR","NEWON","PC","PD","OLDON","OPI","REM","REN","SI","SOL","SYRS" S P(X)=""
S PSJORSTS=11,P("OT")="F^",P("RES")="N",P(4)="A",P(17)="U",Y=$G(^VA(200,+PSJORNP,0)),P(6)=+PSJORNP_U_$P(Y,U)
;; S PSJORSTS=11,P("OT")="F^"_$O(^ORD(101,"B","PSJI OR PAT FLUID OE",0))_";ORD(101,",P("RES")="N",P(4)="A",P(17)="U",Y=$G(^VA(200,+PSJORNP,0)),P(6)=+PSJORNP_U_$P(Y,U)
Q
;
NEWENT ; Get login date/entry code for new order
S P("LOG")=$$DATE^PSJUTL2(),P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORFE 3333 printed Oct 16, 2024@18:05:31 Page 2
PSIVORFE ;BIR/MLM-IV FLUID ORDER ENTRY FOR OE/RR FRONT DOOR. ;26 NOV 97 / 9:55 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**58,81,110,258**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ^VA(200 is supported by DBIA 10060.
+4 ;
EN ; Entry pt. to create new IV Fluid order.
+1 SET PSJORNP=$GET(ORNP)
DO PS^PSIVOREN
if PSJORPF
QUIT
FOR
DO NEWORD
if DONE
QUIT
+2 DO DONE^PSIVORA1
+3 QUIT
+4 ;
NEWORD ; Create new IV Fluid order.
+1 DO SETUP
SET EDIT=58
SET PSIVOK=""
DO EDIT^PSIVEDT
IF '$DATA(DRG("SOL"))
SET DONE=1
QUIT
+2 ; Removed reference to tag 66 of PSIVEDT-backdoor Pharm Prov comments
+3 SET EDIT="57^59"
SET PSIVOK=58
DO EDIT^PSIVEDT
if DONE
QUIT
+4 KILL DA,DIC,ON,P("OLDON")
WRITE !!,"...transcribing this order..."
DO ENGNN^PSGOETO
SET ON=DA
DO PUT531^PSIVORFA
LOCK -^PS(53.1,+ON)
WRITE !
+5 QUIT
+6 ;
GTFLDS ;Ask field no.s to be edited.
+1 NEW PSGEFN
FOR X=1:1:$LENGTH(EDIT,U)
SET PSGEFN(X)=$PIECE(EDIT,U,X)_U_$SELECT($PIECE(EDIT,U,X)=999:"Edit OE/RR Fields",1:$$CODES2^PSIVUTL(53.1,$PIECE(EDIT,U,X)))
+2 SET Y=$PIECE($GET(XQORNOD(0)),"=",2)
+3 SET PSGEFN=1_":"_$LENGTH(EDIT,U)
SET PSJDTYP=$EXTRACT(PSIVAC,1)
if Y=""
DO ENEFA^PSGON
KILL PSJDTYP
IF '$GET(Y)
if PSIVAC="OE"
SET DONE=1
QUIT
+4 SET X=EDIT
SET EDIT=""
FOR X1=1:1:$LENGTH(Y,",")
if $PIECE(X,U,$PIECE(Y,",",X1))
SET $PIECE(EDIT,"^",X1)=$PIECE(X,U,$PIECE(Y,",",X1))
+5 NEW PSIVRENW
SET PSIVRENW=1
+6 DO EDIT^PSIVEDT
+7 KILL PSIVRENW
+8 QUIT
+9 ;
SET ; Set variables needed to create/update orders in the ORDERS file (100).
+1 QUIT
+2 ;*** NO LONGER NEEDED IN 5.0
+3 NEW DRGT,PLN,X
KILL OREVENT,ORETURN,ORSTRT,ORSTOP,ORTX
+4 SET ORL=$$ENORL^PSJUTL($GET(VAIN(4)))
+5 SET ORLOG=P("LOG")
SET ORSTRT=P(2)
SET OREVENT=$SELECT('P(3):"",1:P(3)_";E")
SET ORSTOP=P(3)
SET ORNP=+P(6)
SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"H",1:"I")
+6 ;* S ORPCL=$P(P("OT"),U,2)
DO GTOT^PSIVUTL(P(4))
+7 ;* S Y=P(17),ORSTS=$S("AO"[Y:6,Y="E":7,Y="H":3,Y="D":1,Y="U":11,1:5),ORVP=DFN_";DPT(",ORPK=+ON_$S(ORSTS=5:"P",ORSTS=11:"P",1:"V")
SORTX ;Set up ORTX(.
+1 QUIT
+2 ;*** NO LONGER NEEDED IN 5.0
+3 IF $EXTRACT(P("OT"))="H"
Begin DoDot:1
+4 SET ORTX(1)="* TPN * in "
SET PLN=2
FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
SET ORTX(PLN)=$SELECT($PIECE($GET(DRG("SOL",X)),U,2)]"":$PIECE(DRG("SOL",X),U,2),1:"*NF*")
SET PLN=PLN+1
+5 SET ORTX(PLN)=$SELECT(P(8)]"":P(8),1:P(9))
SET PLN=PLN+1
End DoDot:1
+6 IF $EXTRACT(P("OT"))="F"
DO ORTXF
+7 IF $EXTRACT(P("OT"))="I"
SET ORTX(1)=$PIECE(P("PD"),U,2)
SET ORTX(2)="Give: "_$PIECE(P("MR"),U,2)_" "_$SELECT(P(9)]"":P(9),1:P(8))
SET PLN=3
+8 SET ORTX(1)=$SELECT($GET(P("FRES"))="R":"RENEWED -",$GET(P("RES"))="R":"RENEWAL -",1:"")_ORTX(1)
+9 ;I $D(^PS(53.45,+$G(PSIVUP),4)) F PC=0:0 S PC=$O(^PS(53.45,PSIVUP,4,PC)) Q:'PC S ORTX(PLN)=$G(^PS(53.45,PSIVUP,4,PC,0)),PLN=PLN+1
+10 QUIT
+11 ;
ORTXF ; Set up ORTX( for Fluids.
+1 QUIT
+2 ;*** NO LONGER NEEDED IN 5.0
+3 NEW SOLF
+4 SET PLN=1
FOR DRGT="AD","SOL"
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
if 'DRGI
QUIT
Begin DoDot:1
+5 SET ORTX(PLN)=$SELECT($PIECE(DRG(DRGT,DRGI),U,2)="":"*NF*",1:$PIECE(DRG(DRGT,DRGI),U,2)_" "_$PIECE(DRG(DRGT,DRGI),U,3))
SET PLN=PLN+1
IF DRGT="SOL"
IF ('$GET(SOLF))
SET ORTX(PLN-1)="in "_ORTX(PLN-1)
SET SOLF=1
End DoDot:1
+6 SET ORTX(PLN)=$SELECT(P(8)]"":P(8),1:P(9))
SET PLN=PLN+1
+7 QUIT
+8 ;
SETUP ; Initialize variables.
+1 KILL DRG
DO NEWENT
SET DRGN=""
FOR X=2,3,5,7,8,9,11,15,23,"AD","DO","IVRM","MR","NEWON","PC","PD","OLDON","OPI","REM","REN","SI","SOL","SYRS"
SET P(X)=""
+2 SET PSJORSTS=11
SET P("OT")="F^"
SET P("RES")="N"
SET P(4)="A"
SET P(17)="U"
SET Y=$GET(^VA(200,+PSJORNP,0))
SET P(6)=+PSJORNP_U_$PIECE(Y,U)
+3 ;; S PSJORSTS=11,P("OT")="F^"_$O(^ORD(101,"B","PSJI OR PAT FLUID OE",0))_";ORD(101,",P("RES")="N",P(4)="A",P(17)="U",Y=$G(^VA(200,+PSJORNP,0)),P(6)=+PSJORNP_U_$P(Y,U)
+4 QUIT
+5 ;
NEWENT ; Get login date/entry code for new order
+1 SET P("LOG")=$$DATE^PSJUTL2()
SET P("CLRK")=DUZ_U_$PIECE($GET(^VA(200,DUZ,0)),U)
+2 QUIT
