- PSIVORE2 ;BIR/RGY,PR,MLM-ACT, NEW ORDER (CONT. OF PSIVORE1) ;16 Mar 99 / 2:16 PM
- ;;5.0; INPATIENT MEDICATIONS ;**21,58,101**;16 DEC 97
- ;
- ; References to ^PS(55 supported by DBIA #2191.
- ;
- DEQ ;
- S P(4)=$P(^PS(55,DFN,"IV",+ON,0),U,4),ACTION=1,TRACK=4 D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:P(4)'="H"
- K ;
- S:$D(ZTQUEUED) ZTREQ="@" K PSIVMI,PSI,OD,PSIVEC,PSIVSC,I,PSIVNOL,PSIV1,PSIVA,PSIVDOSE,PSGCNT,PSGSA,PSCT,PDOSE,PDATE,PSIVLABN,UP1,PLAST Q
- TL ;
- W ! F X=3:3:24 W " ",$S($L(X)=1:" ",1:""),X
- W ! F X=1:1:24 W "..:"
- K PSI F X=0:0 S X=$O(^PS(59.5,PSIVSN,2,"AC",P(4),X)) Q:'X S PSI(+("."_$P(^PS(59.5,PSIVSN,2,X,0),U)))=$S($P($P(^(0),U,6),".")=DT:"*",1:"")
- S PSI=P(4) D TL1
- K PSI S:'$D(PSGSA) PSGSA="" F PSI=1:1 S X=$P(PSGSA," ",PSI) Q:X="" I X S PSI(X#1)=""
- S PSI="^" D TL1
- D NOW^%DTC S Y=% S PSI(Y#1)="",PSI="N" D TL1 Q
- TL1 ;
- W ! S Y="" F X=0:0 S Y=$O(PSI(Y)) Q:'Y W ?3*$E(Y_"000",2,3)-1+$S($E(Y_"000",4,5)>40:2,$E(Y_"000",4,5)>20:1,1:0),PSI,PSI(Y)
- K PSI Q
- C ;
- S SNM=0 F DAT=0:0 S DAT=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,DAT)) Q:'DAT S SNM=SNM+$P(^(DAT),U)
- Q
- ;
- CONVER(X,Y) ;
- ;***$$FMADD^XLFDT(DT.HH,D,H,M,S) returns the DT.HH+(D,H,M,S)
- ;*I +P(15)>1440 S X=$$FMADD^XLFDT($P(PSGSA," "),"","",(P(15)*(Y-1))) Q X
- I +P(15)>1440 S X=$$CONVER1($P(PSGSA," "),P(15),(Y-1)) Q X
- S PDOSE=X S:Y=2 PDATE=$E($P(PSGSA," "),1,7)
- I $P(PSGSA," ",Y-1)#1'<PDOSE!(P(15)>1440) S X1=PDATE,X2=1 D C^%DTC S PDATE=X,X=X_PDOSE Q X
- S X=PDATE_PDOSE
- Q X
- ;
- CONVER1(ORDDT,X,Y) ;
- ;* This sub-routine is necessary when a schedule such as q36h was
- ;* entered and the Start date is such as T-3@1200. Without these codes
- ;* instead of schedule due for T@2400 it will display as T+1@0000.
- NEW DAYS,MINS S (DAYS,MINS)=0
- S DAYS=(X*Y)\1440,MINS=(X*Y)#1440
- S X=$$FMADD^XLFDT(ORDDT,DAYS,"",MINS)
- Q X
- ;
- INCOMP ; Delete order missing critical information.
- N DIR,PSIVAC W !!,$C(7),"THIS ORDER IS NOT USABLE!",!,"Enter ""D"" to Delete, or ""B"" to Bypass",!
- S DIR(0)="SOA^D:DELETE;B:BYPASS",DIR("A")="ACTION (B/D): ",DIR("??")="^S HELP=""INCOMP"" D ^PSIVHLP2" D ^DIR K DIR Q:Y="B"!$D(DIRUT) S PSIVAC="N"
- ;
- DEL55 ; Delete order from 55.
- I ON55'["V"!($G(P(21))]"") Q
- S DIK="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+ON55 D ^DIK W:'$G(PSIVORFA) $C(7),"...Order ",$S($E($G(PSIVAC),2)="N":"deleted.",1:"unchanged.")
- N DA,DIK,ORIFN S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) I ORIFN,$E($G(PSIVAC),2)="N" D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DELETED")
- L -^PS(55,DFN,"IV",+ON55)
- Q
- ;
- NEW ; New order entry
- D NEWENT^PSIVORFE S DRGN="",P("IVRM")=+PSIVSN_U_$P($G(^PS(59.5,+PSIVSN,0)),U)
- K DRG,PSGFDX F X="AD","DRG","LF","LFA","CUM","MR","SOL","OPI","OT","SYRS","REM","SI",2,3,4,5,7,8,9,11,12,15,17,23 S:'$D(P(X)) P(X)=""
- S P(17)="A",P(4)=$E($G(PSIVTYPE)) S:"CS"[P(4) P(23)=$P($G(PSIVTYPE),U,2)
- D:P(4)="" 53^PSIVORC1 Q:$G(P(4))="" S Y=$P($G(^PS(55,DFN,5.1)),U,2),P(6)=Y_U_$P($G(^VA(200,+Y,0)),U)
- D OTYP^PSIVORC1 S PSIVOK="",EDIT="57^58^59^3"_$S(P("DTYP")=1:"^26^39",1:"")_"^63^64^10^25^1"
- D EDIT^PSIVEDT Q:'$G(P(2)) D GTOT^PSIVUTL(P(4)) D:$G(P("PD"))="" GTPD
- Q
- ;
- GTPD ; Find Orderable Item/dosage ordered for IM.
- S P("PD")="" F DRGT="AD","SOL" Q:P("PD") F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI!P("PD") D
- . S X=DRG(DRGT,DRGI) S:$P(X,U,6) P("PD")=$P(X,U,6)_U_$$OIDF^PSJLMUT1(+$P(X,U,6))
- . S P("DO")=$P(X,U,3)
- . ;S:$G(P("DO"))="" P("DO")=$P(X,U,3)
- Q
- PSIVORE2 ;BIR/RGY,PR,MLM-ACT, NEW ORDER (CONT. OF PSIVORE1) ;16 Mar 99 / 2:16 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**21,58,101**;16 DEC 97
- +2 ;
- +3 ; References to ^PS(55 supported by DBIA #2191.
- +4 ;
- DEQ ;
- +1 SET P(4)=$PIECE(^PS(55,DFN,"IV",+ON,0),U,4)
- SET ACTION=1
- SET TRACK=4
- DO ^PSIVLTR
- IF P(4)="H"
- DO ^PSIVHYPL
- IF P(4)'="H"
- DO ^PSIVLABL
- K ;
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL PSIVMI,PSI,OD,PSIVEC,PSIVSC,I,PSIVNOL,PSIV1,PSIVA,PSIVDOSE,PSGCNT,PSGSA,PSCT,PDOSE,PDATE,PSIVLABN,UP1,PLAST
- QUIT
- TL ;
- +1 WRITE !
- FOR X=3:3:24
- WRITE " ",$SELECT($LENGTH(X)=1:" ",1:""),X
- +2 WRITE !
- FOR X=1:1:24
- WRITE "..:"
- +3 KILL PSI
- FOR X=0:0
- SET X=$ORDER(^PS(59.5,PSIVSN,2,"AC",P(4),X))
- IF 'X
- QUIT
- SET PSI(+("."_$PIECE(^PS(59.5,PSIVSN,2,X,0),U)))=$SELECT($PIECE($PIECE(^(0),U,6),".")=DT:"*",1:"")
- +4 SET PSI=P(4)
- DO TL1
- +5 KILL PSI
- IF '$DATA(PSGSA)
- SET PSGSA=""
- FOR PSI=1:1
- SET X=$PIECE(PSGSA," ",PSI)
- IF X=""
- QUIT
- IF X
- SET PSI(X#1)=""
- +6 SET PSI="^"
- DO TL1
- +7 DO NOW^%DTC
- SET Y=%
- SET PSI(Y#1)=""
- SET PSI="N"
- DO TL1
- QUIT
- TL1 ;
- +1 WRITE !
- SET Y=""
- FOR X=0:0
- SET Y=$ORDER(PSI(Y))
- IF 'Y
- QUIT
- WRITE ?3*$EXTRACT(Y_"000",2,3)-1+$SELECT($EXTRACT(Y_"000",4,5)>40:2,$EXTRACT(Y_"000",4,5)>20:1,1:0),PSI,PSI(Y)
- +2 KILL PSI
- QUIT
- C ;
- +1 SET SNM=0
- FOR DAT=0:0
- SET DAT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,DAT))
- IF 'DAT
- QUIT
- SET SNM=SNM+$PIECE(^(DAT),U)
- +2 QUIT
- +3 ;
- CONVER(X,Y) ;
- +1 ;***$$FMADD^XLFDT(DT.HH,D,H,M,S) returns the DT.HH+(D,H,M,S)
- +2 ;*I +P(15)>1440 S X=$$FMADD^XLFDT($P(PSGSA," "),"","",(P(15)*(Y-1))) Q X
- +3 IF +P(15)>1440
- SET X=$$CONVER1($PIECE(PSGSA," "),P(15),(Y-1))
- QUIT X
- +4 SET PDOSE=X
- IF Y=2
- SET PDATE=$EXTRACT($PIECE(PSGSA," "),1,7)
- +5 IF $PIECE(PSGSA," ",Y-1)#1'<PDOSE!(P(15)>1440)
- SET X1=PDATE
- SET X2=1
- DO C^%DTC
- SET PDATE=X
- SET X=X_PDOSE
- QUIT X
- +6 SET X=PDATE_PDOSE
- +7 QUIT X
- +8 ;
- CONVER1(ORDDT,X,Y) ;
- +1 ;* This sub-routine is necessary when a schedule such as q36h was
- +2 ;* entered and the Start date is such as T-3@1200. Without these codes
- +3 ;* instead of schedule due for T@2400 it will display as T+1@0000.
- +4 NEW DAYS,MINS
- SET (DAYS,MINS)=0
- +5 SET DAYS=(X*Y)\1440
- SET MINS=(X*Y)#1440
- +6 SET X=$$FMADD^XLFDT(ORDDT,DAYS,"",MINS)
- +7 QUIT X
- +8 ;
- INCOMP ; Delete order missing critical information.
- +1 NEW DIR,PSIVAC
- WRITE !!,$CHAR(7),"THIS ORDER IS NOT USABLE!",!,"Enter ""D"" to Delete, or ""B"" to Bypass",!
- +2 SET DIR(0)="SOA^D:DELETE;B:BYPASS"
- SET DIR("A")="ACTION (B/D): "
- SET DIR("??")="^S HELP=""INCOMP"" D ^PSIVHLP2"
- DO ^DIR
- KILL DIR
- IF Y="B"!$DATA(DIRUT)
- QUIT
- SET PSIVAC="N"
- +3 ;
- DEL55 ; Delete order from 55.
- +1 IF ON55'["V"!($GET(P(21))]"")
- QUIT
- +2 SET DIK="^PS(55,"_DFN_",""IV"","
- SET DA(1)=DFN
- SET DA=+ON55
- DO ^DIK
- IF '$GET(PSIVORFA)
- WRITE $CHAR(7),"...Order ",$SELECT($EXTRACT($GET(PSIVAC),2)="N":"deleted.",1:"unchanged.")
- +3 NEW DA,DIK,ORIFN
- SET ORIFN=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,21)
- IF ORIFN
- IF $EXTRACT($GET(PSIVAC),2)="N"
- DO EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DELETED")
- +4 LOCK -^PS(55,DFN,"IV",+ON55)
- +5 QUIT
- +6 ;
- NEW ; New order entry
- +1 DO NEWENT^PSIVORFE
- SET DRGN=""
- SET P("IVRM")=+PSIVSN_U_$PIECE($GET(^PS(59.5,+PSIVSN,0)),U)
- +2 KILL DRG,PSGFDX
- FOR X="AD","DRG","LF","LFA","CUM","MR","SOL","OPI","OT","SYRS","REM","SI",2,3,4,5,7,8,9,11,12,15,17,23
- IF '$DATA(P(X))
- SET P(X)=""
- +3 SET P(17)="A"
- SET P(4)=$EXTRACT($GET(PSIVTYPE))
- IF "CS"[P(4)
- SET P(23)=$PIECE($GET(PSIVTYPE),U,2)
- +4 IF P(4)=""
- DO 53^PSIVORC1
- IF $GET(P(4))=""
- QUIT
- SET Y=$PIECE($GET(^PS(55,DFN,5.1)),U,2)
- SET P(6)=Y_U_$PIECE($GET(^VA(200,+Y,0)),U)
- +5 DO OTYP^PSIVORC1
- SET PSIVOK=""
- SET EDIT="57^58^59^3"_$SELECT(P("DTYP")=1:"^26^39",1:"")_"^63^64^10^25^1"
- +6 DO EDIT^PSIVEDT
- IF '$GET(P(2))
- QUIT
- DO GTOT^PSIVUTL(P(4))
- IF $GET(P("PD"))=""
- DO GTPD
- +7 QUIT
- +8 ;
- GTPD ; Find Orderable Item/dosage ordered for IM.
- +1 SET P("PD")=""
- FOR DRGT="AD","SOL"
- IF P("PD")
- QUIT
- FOR DRGI=0:0
- SET DRGI=$ORDER(DRG(DRGT,DRGI))
- IF 'DRGI!P("PD")
- QUIT
- Begin DoDot:1
- +2 SET X=DRG(DRGT,DRGI)
- IF $PIECE(X,U,6)
- SET P("PD")=$PIECE(X,U,6)_U_$$OIDF^PSJLMUT1(+$PIECE(X,U,6))
- +3 SET P("DO")=$PIECE(X,U,3)
- +4 ;S:$G(P("DO"))="" P("DO")=$P(X,U,3)
- End DoDot:1
- +5 QUIT