PSGOES ;BIR/CML3-CREATE ORDERS USING ORDER SET ;19 Feb 99 / 12:53 PM
;;5.0; INPATIENT MEDICATIONS ;**12,22,30,34,50,58,111**;16 DEC 97
;
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PSDRUG is supported by DBIA 2192.
;
K DIC,PSGOEOS S X=$P(X,"S.",2),DIC="^PS(53.2,",DIC(0)="QEM" D ^DIC K DIC G:Y'>0 DONE W " (ORDER SET)" S PSGOESDA=+Y,PSGOES=1
I '$D(^PS(53.2,+Y,2)) W " Invalid Order Set" Q
I $P(PSJSYSU,";",2) S PSGOESPR=DUZ
E D G:Y'>0 DONE
.S DIC="^VA(200,",DIC(0)="QEAM",DIC("A")="Select PROVIDER: ",X=$P($G(^PS(55,PSGP,5.1)),"^",2) I X S X=$P($G(^VA(200,X,0)),"^") I X]"" S Y=^("PS") I Y,$S('$P(Y,"^",4):1,1:$P(Y,"^",4)>DT) S DIC("B")=X
.S DIC("S")="S X(1)=$G(^(""PS"")) I X(1),$S('$P(X(1),""^"",4):1,1:$P(X(1),""^"",4)>DT)" W ! D ^DIC K DIC I Y'>0 W $C(7),!!,"Provider is required for order sets." Q
.S PSGOESPR=+Y S:$P($G(^PS(55,PSGP,5.1)),"^",2)'=+Y $P(^(5.1),"^",2)=+Y
S PSJNOO=$$ENNOO^PSJUTL5("N")
I $G(PSJNOO)<0 W !,$C(7),"...order set not entered..." G DONE
F PSGOESN=0:0 S PSGOESN=$O(^PS(53.2,PSGOESDA,2,PSGOESN)) Q:'PSGOESN I $D(^(PSGOESN,0)) S OSND=^(0) I $S($P(OSND,"^",3)="":0,$P(OSND,"^",4)="":0,$P(OSND,"^",4)="OC":1,1:$P(OSND,"^",5)]"") S PSGSI=$P($G(^(1)),"^") D GND Q:PSGQUIT
;
DONE ;
K PSJNOON,PSJNOO
S X="S.X" K %DT,N,OSND,PSGOESDA,PSGDDRG,PSGOESI,PSGOES,PSGOEOS,PSGOESN,PSGOESPR,PSGQUIT,PSGX,SDT,STDAY,X1,X2 Q
;
GND ;
K PSGOEE,PSGSCH
S (PSGPDRG,PSGX)=+OSND,PSGPDRGN=$P($G(^PS(50.7,PSGPDRG,0)),"^") S:PSGPDRGN="" PSGPDRGN=PSGPDRG W !!,"...entering ",$S(PSGPDRGN'=PSGPDRG:PSGPDRGN,1:"** UNKNOWN **"),"..." K Y,DIRUT D END^PSGSICHK S PSGQUIT=$D(DIRUT) Q:$G(Y)<0
S PSGNEDFD=$P(OSND,"^",2,5),PSGMR=$P(OSND,"^",3),PSGST=$P(OSND,"^",4),PSGDO=$P(OSND,"^",9),PSGMRN=$$ENMRN^PSGMI(PSGMR)
S:PSGMRN="" PSGMRN=PSGMR D NOW^%DTC S PSGDT=+$E(%,1,12) I PSGST="OC" S PSGSCH="ON CALL",(PSGS0XT,PSGS0Y)=""
E S X=$P(OSND,"^",5) W "." S:X X="`"_X D ENOS^PSGS0 S:$D(X) PSGSCH=X I '$D(X) S (PSGSCH,PSGS0XT,PSGS0Y)=""
S (PSGNESD,PSGNEFD)="" W "." I $P(OSND,"^",11)]"" S %DT="T",X=$P(OSND,"^",11) D ^%DT S PSGNESD=Y D ENFD^PSGNE3(PSGDT)
D:$P(OSND,"^",11)="" ^PSGNE3 K PSGDRG,PSGORQF,^PS(53.45,PSJSYSP,1),^(2) S (N,Q)=0
F S Q=$O(^PS(53.2,PSGOESDA,2,PSGOESN,2,Q)) Q:'Q!$D(PSGORQF) S PSGDRG=$G(^(Q,0)) I PSGDRG D
.D ENDDC^PSGSICHK(PSGP,+PSGDRG) Q:$D(PSGORQF)
.S:$P(PSGDRG,U,2)="" $P(PSGDRG,U,2)=1
.S N=N+1,^PS(53.45,PSJSYSP,2,N,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",+PSGDRG,N)="" W "."
.I $P(^PSDRUG(+PSGDRG,2),U,3)'["U"!($S('+$G(^PSDRUG(+PSGDRG,"I")):0,^("I")'>DT:1,1:0)) S PSGOEAV="0^1" W:PSJSYSU $C(7),!?5,"...AS NON-VERIFIED - DATA INCOMPLETE..."
I N S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_N_"^"_N
I $D(PSGORQF) W !,?5,"...ORDER FOR ",PSGPDRGN," NOT ENTERED...",! Q
;I PSGOEAV,$S($D(PSGOEOS):1,'PSGPDRG:1,PSGPDRG=PSGPDRGN:1,'PSGMR:1,PSGMR=PSGMRN:1,PSGSCH="":1,PSGST="":1,'PSGNESD:1,'PSGNEFD:1,+PSJSYSU=3:'N,1:0) S PSGOEAV="0^1" W:('$D(PSGOEOS)&PSJSYSU) $C(7),!?5,"...AS NON-VERIFIED - DATA INCOMPLETE..."
I PSGOEAV,$S('PSGPDRG:1,PSGPDRG=PSGPDRGN:1,'PSGMR:1,PSGMR=PSGMRN:1,PSGSCH="":1,PSGST="":1,'PSGNESD:1,'PSGNEFD:1,+PSJSYSU=3:'N,1:0) S PSGOEAV="0^1" W:('$D(PSGOES)&PSJSYSU) $C(7),!?5,"...AS NON-VERIFIED - DATA INCOMPLETE..."
S (PSGHSM,PSGSM)="",PSGPR=PSGOESPR D ^PSGOETO S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
; pharmacist label check, build label for order set only if auto verify turned on
I PSJSYSL>0,(PSGOEAV),($P($G(^PS(55,PSGP,5,$S($D(DA):DA,1:+PSGORD),0)),U,9)="A") D
.S $P(^PS(55,PSGP,5,$S($D(DA):DA,1:+PSGORD),7),U)=PSGDT S:$P(^(7),U,2)="" $P(^(7),U,2)="N" S PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD D ENL^PSGVDS
; ward clerk label check
I PSJSYSL>0,$P(PSJSYSU,";",3)<3,"12"[$P(PSJSYSW0,"^",12),'(PSGOEAV) D
.I PSGORD["P" S $P(^PS(53.1,$S($D(DA):DA,1:+PSGORD),7),U)=PSGDT S:$P(^(7),U,2)="" $P(^(7),U,2)="N"
.I PSGORD'["P" S $P(^PS(55,PSGP,5,$S($D(DA):DA,1:+PSGORD),7),U)=PSGDT S:$P(^(7),U,2)="" $P(^(7),U,2)="N"
.S PSGTOL=2,PSGUOW=DUZ,PSGTOO=2,DA=+PSGORD D ENL^PSGVDS
Q
PSGOES ;BIR/CML3-CREATE ORDERS USING ORDER SET ;19 Feb 99 / 12:53 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**12,22,30,34,50,58,111**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+4 ; Reference to ^PS(55 is supported by DBIA 2191.
+5 ; Reference to ^PSDRUG is supported by DBIA 2192.
+6 ;
+7 KILL DIC,PSGOEOS
SET X=$PIECE(X,"S.",2)
SET DIC="^PS(53.2,"
SET DIC(0)="QEM"
DO ^DIC
KILL DIC
IF Y'>0
GOTO DONE
WRITE " (ORDER SET)"
SET PSGOESDA=+Y
SET PSGOES=1
+8 IF '$DATA(^PS(53.2,+Y,2))
WRITE " Invalid Order Set"
QUIT
+9 IF $PIECE(PSJSYSU,";",2)
SET PSGOESPR=DUZ
+10 IF '$TEST
Begin DoDot:1
+11 SET DIC="^VA(200,"
SET DIC(0)="QEAM"
SET DIC("A")="Select PROVIDER: "
SET X=$PIECE($GET(^PS(55,PSGP,5.1)),"^",2)
IF X
SET X=$PIECE($GET(^VA(200,X,0)),"^")
IF X]""
SET Y=^("PS")
IF Y
IF $SELECT('$PIECE(Y,"^",4):1,1:$PIECE(Y,"^",4)>DT)
SET DIC("B")=X
+12 SET DIC("S")="S X(1)=$G(^(""PS"")) I X(1),$S('$P(X(1),""^"",4):1,1:$P(X(1),""^"",4)>DT)"
WRITE !
DO ^DIC
KILL DIC
IF Y'>0
WRITE $CHAR(7),!!,"Provider is required for order sets."
QUIT
+13 SET PSGOESPR=+Y
IF $PIECE($GET(^PS(55,PSGP,5.1)),"^",2)'=+Y
SET $PIECE(^(5.1),"^",2)=+Y
End DoDot:1
IF Y'>0
GOTO DONE
+14 SET PSJNOO=$$ENNOO^PSJUTL5("N")
+15 IF $GET(PSJNOO)<0
WRITE !,$CHAR(7),"...order set not entered..."
GOTO DONE
+16 FOR PSGOESN=0:0
SET PSGOESN=$ORDER(^PS(53.2,PSGOESDA,2,PSGOESN))
IF 'PSGOESN
QUIT
IF $DATA(^(PSGOESN,0))
SET OSND=^(0)
IF $SELECT($PIECE(OSND,"^",3)="":0,$PIECE(OSND,"^",4)="":0,$PIECE(OSND,"^",4)="OC":1,1:$PIECE(OSND,"^",5)]"")
SET PSGSI=$PIECE($GET(^(1)),"^")
DO GND
IF PSGQUIT
QUIT
+17 ;
DONE ;
+1 KILL PSJNOON,PSJNOO
+2 SET X="S.X"
KILL %DT,N,OSND,PSGOESDA,PSGDDRG,PSGOESI,PSGOES,PSGOEOS,PSGOESN,PSGOESPR,PSGQUIT,PSGX,SDT,STDAY,X1,X2
QUIT
+3 ;
GND ;
+1 KILL PSGOEE,PSGSCH
+2 SET (PSGPDRG,PSGX)=+OSND
SET PSGPDRGN=$PIECE($GET(^PS(50.7,PSGPDRG,0)),"^")
IF PSGPDRGN=""
SET PSGPDRGN=PSGPDRG
WRITE !!,"...entering ",$SELECT(PSGPDRGN'=PSGPDRG:PSGPDRGN,1:"** UNKNOWN **"),"..."
KILL Y,DIRUT
DO END^PSGSICHK
SET PSGQUIT=$DATA(DIRUT)
IF $GET(Y)<0
QUIT
+3 SET PSGNEDFD=$PIECE(OSND,"^",2,5)
SET PSGMR=$PIECE(OSND,"^",3)
SET PSGST=$PIECE(OSND,"^",4)
SET PSGDO=$PIECE(OSND,"^",9)
SET PSGMRN=$$ENMRN^PSGMI(PSGMR)
+4 IF PSGMRN=""
SET PSGMRN=PSGMR
DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
IF PSGST="OC"
SET PSGSCH="ON CALL"
SET (PSGS0XT,PSGS0Y)=""
+5 IF '$TEST
SET X=$PIECE(OSND,"^",5)
WRITE "."
IF X
SET X="`"_X
DO ENOS^PSGS0
IF $DATA(X)
SET PSGSCH=X
IF '$DATA(X)
SET (PSGSCH,PSGS0XT,PSGS0Y)=""
+6 SET (PSGNESD,PSGNEFD)=""
WRITE "."
IF $PIECE(OSND,"^",11)]""
SET %DT="T"
SET X=$PIECE(OSND,"^",11)
DO ^%DT
SET PSGNESD=Y
DO ENFD^PSGNE3(PSGDT)
+7 IF $PIECE(OSND,"^",11)=""
DO ^PSGNE3
KILL PSGDRG,PSGORQF,^PS(53.45,PSJSYSP,1),^(2)
SET (N,Q)=0
+8 FOR
SET Q=$ORDER(^PS(53.2,PSGOESDA,2,PSGOESN,2,Q))
IF 'Q!$DATA(PSGORQF)
QUIT
SET PSGDRG=$GET(^(Q,0))
IF PSGDRG
Begin DoDot:1
+9 DO ENDDC^PSGSICHK(PSGP,+PSGDRG)
IF $DATA(PSGORQF)
QUIT
+10 IF $PIECE(PSGDRG,U,2)=""
SET $PIECE(PSGDRG,U,2)=1
+11 SET N=N+1
SET ^PS(53.45,PSJSYSP,2,N,0)=PSGDRG
SET ^PS(53.45,PSJSYSP,2,"B",+PSGDRG,N)=""
WRITE "."
+12 IF $PIECE(^PSDRUG(+PSGDRG,2),U,3)'["U"!($SELECT('+$GET(^PSDRUG(+PSGDRG,"I")):0,^("I")'>DT:1,1:0))
SET PSGOEAV="0^1"
IF PSJSYSU
WRITE $CHAR(7),!?5,"...AS NON-VERIFIED - DATA INCOMPLETE..."
End DoDot:1
+13 IF N
SET ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_N_"^"_N
+14 IF $DATA(PSGORQF)
WRITE !,?5,"...ORDER FOR ",PSGPDRGN," NOT ENTERED...",!
QUIT
+15 ;I PSGOEAV,$S($D(PSGOEOS):1,'PSGPDRG:1,PSGPDRG=PSGPDRGN:1,'PSGMR:1,PSGMR=PSGMRN:1,PSGSCH="":1,PSGST="":1,'PSGNESD:1,'PSGNEFD:1,+PSJSYSU=3:'N,1:0) S PSGOEAV="0^1" W:('$D(PSGOEOS)&PSJSYSU) $C(7),!?5,"...AS NON-VERIFIED - DATA INCOMPLETE..."
+16 IF PSGOEAV
IF $SELECT('PSGPDRG:1,PSGPDRG=PSGPDRGN:1,'PSGMR:1,PSGMR=PSGMRN:1,PSGSCH="":1,PSGST="":1,'PSGNESD:1,'PSGNEFD:1,+PSJSYSU=3:'N,1:0)
SET PSGOEAV="0^1"
IF ('$DATA(PSGOES)&PSJSYSU)
WRITE $CHAR(7),!?5,"...AS NON-VERIFIED - DATA INCOMPLETE..."
+17 SET (PSGHSM,PSGSM)=""
SET PSGPR=PSGOESPR
DO ^PSGOETO
SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
+18 ; pharmacist label check, build label for order set only if auto verify turned on
+19 IF PSJSYSL>0
IF (PSGOEAV)
IF ($PIECE($GET(^PS(55,PSGP,5,$SELECT($DATA(DA):DA,1:+PSGORD),0)),U,9)="A")
Begin DoDot:1
+20 SET $PIECE(^PS(55,PSGP,5,$SELECT($DATA(DA):DA,1:+PSGORD),7),U)=PSGDT
IF $PIECE(^(7),U,2)=""
SET $PIECE(^(7),U,2)="N"
SET PSGTOL=2
SET PSGUOW=DUZ
SET PSGTOO=1
SET DA=+PSGORD
DO ENL^PSGVDS
End DoDot:1
+21 ; ward clerk label check
+22 IF PSJSYSL>0
IF $PIECE(PSJSYSU,";",3)<3
IF "12"[$PIECE(PSJSYSW0,"^",12)
IF '(PSGOEAV)
Begin DoDot:1
+23 IF PSGORD["P"
SET $PIECE(^PS(53.1,$SELECT($DATA(DA):DA,1:+PSGORD),7),U)=PSGDT
IF $PIECE(^(7),U,2)=""
SET $PIECE(^(7),U,2)="N"
+24 IF PSGORD'["P"
SET $PIECE(^PS(55,PSGP,5,$SELECT($DATA(DA):DA,1:+PSGORD),7),U)=PSGDT
IF $PIECE(^(7),U,2)=""
SET $PIECE(^(7),U,2)="N"
+25 SET PSGTOL=2
SET PSGUOW=DUZ
SET PSGTOO=2
SET DA=+PSGORD
DO ENL^PSGVDS
End DoDot:1
+26 QUIT
