- 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,181,263,309,281,256,368**;16 DEC 97;Build 2
- ;
- ; 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.
- ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
- ;
- NEW PSJNOOSV
- 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,PSJNOOSV)=$$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,PSJNOOSV
- S X="S.X" K %DT,N,OSND,PSGOESDA,PSGDDRG,PSGOESI,PSGOES,PSGOEOS,PSGOESN,PSGOESPR,PSGQUIT,PSGX,SDT,STDAY,X1,X2 Q
- ;
- GND ;
- NEW PSJOCDS,PSJALLGY,PSJMULDD,PSJOLDNM,PSGRF,ND2P1
- K PSGOEE,PSGSCH,PSGORD
- K ^TMP("PSODAOC",$J)
- S:'$D(PSJNOO) PSJNOO=$G(PSJNOOSV)
- S (PSGPDRG,PSGX)=+OSND,PSGPDRGN=$P($G(^PS(50.7,PSGPDRG,0)),"^") S:PSGPDRGN="" PSGPDRGN=PSGPDRG
- S PSGRF=$P($G(^PS(50.7,PSGPDRG,4),0),U,1)
- 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)
- ;PSJ*5*256
- I '+$P(OSND,"^",5) S PSJOLDNM("ORD_SCHD")=$P(OSND,"^",5) I $$CHKSCHD^PSJMISC2(.PSJOLDNM) Q
- 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 S:$G(PSJOLDNM("NEW_SCHD"))]"" X=PSJOLDNM("NEW_SCHD") 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
- K PSJALLGY
- ;If PSJMULDD >1 then the order has mutliple DD and it will flag ENDDC^PSGSICHK to display the OI name instead of DD name
- S PSJMULDD=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
- .S PSJALLGY(+PSGDRG)="",PSJMULDD=PSJMULDD+1
- .;D ENDDC^PSGSICHK(PSGP,+PSGDRG) Q:$D(PSGORQF)
- .;D IN^PSJOCDS($G(PSGORD),"UD",+PSGDRG) Q:$D(PSGORQF)
- .;D CONT^PSJOCDT 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..."
- S PSGDRG=$O(PSJALLGY(0)) Q:'+PSGDRG
- D FULL^VALM1
- D ENDDC^PSGSICHK(PSGP,+PSGDRG) Q:$D(PSGORQF)
- D IN^PSJOCDS($G(PSGORD),"UD",+PSGDRG) Q:$D(PSGORQF)
- ;*309 - Remove second continue prompt
- ;D CONT^PSJOCDT Q:$D(PSGORQF)
- I N S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_N_"^"_N
- I $G(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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOES 5013 printed Mar 13, 2025@21:07:19 Page 2
- 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,181,263,309,281,256,368**;16 DEC 97;Build 2
- +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 ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
- +7 ;
- +8 NEW PSJNOOSV
- +9 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
- +10 IF '$DATA(^PS(53.2,+Y,2))
- WRITE " Invalid Order Set"
- QUIT
- +11 IF $PIECE(PSJSYSU,";",2)
- SET PSGOESPR=DUZ
- +12 IF '$TEST
- Begin DoDot:1
- +13 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
- +14 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
- +15 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
- +16 SET (PSJNOO,PSJNOOSV)=$$ENNOO^PSJUTL5("N")
- +17 IF $GET(PSJNOO)<0
- WRITE !,$CHAR(7),"...order set not entered..."
- GOTO DONE
- +18 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
- +19 ;
- DONE ;
- +1 KILL PSJNOON,PSJNOO,PSJNOOSV
- +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 NEW PSJOCDS,PSJALLGY,PSJMULDD,PSJOLDNM,PSGRF,ND2P1
- +2 KILL PSGOEE,PSGSCH,PSGORD
- +3 KILL ^TMP("PSODAOC",$JOB)
- +4 if '$DATA(PSJNOO)
- SET PSJNOO=$GET(PSJNOOSV)
- +5 SET (PSGPDRG,PSGX)=+OSND
- SET PSGPDRGN=$PIECE($GET(^PS(50.7,PSGPDRG,0)),"^")
- if PSGPDRGN=""
- SET PSGPDRGN=PSGPDRG
- +6 SET PSGRF=$PIECE($GET(^PS(50.7,PSGPDRG,4),0),U,1)
- +7 WRITE !!,"...entering ",$SELECT(PSGPDRGN'=PSGPDRG:PSGPDRGN,1:"** UNKNOWN **"),"..."
- +8 KILL Y,DIRUT
- DO END^PSGSICHK
- SET PSGQUIT=$DATA(DIRUT)
- if $GET(Y)<0
- QUIT
- +9 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)
- +10 ;PSJ*5*256
- +11 IF '+$PIECE(OSND,"^",5)
- SET PSJOLDNM("ORD_SCHD")=$PIECE(OSND,"^",5)
- IF $$CHKSCHD^PSJMISC2(.PSJOLDNM)
- QUIT
- +12 if PSGMRN=""
- SET PSGMRN=PSGMR
- DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- IF PSGST="OC"
- SET PSGSCH="ON CALL"
- SET (PSGS0XT,PSGS0Y)=""
- +13 IF '$TEST
- SET X=$PIECE(OSND,"^",5)
- WRITE "."
- if X
- SET X="`"_X
- if $GET(PSJOLDNM("NEW_SCHD"))]""
- SET X=PSJOLDNM("NEW_SCHD")
- DO ENOS^PSGS0
- if $DATA(X)
- SET PSGSCH=X
- IF '$DATA(X)
- SET (PSGSCH,PSGS0XT,PSGS0Y)=""
- +14 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)
- +15 if $PIECE(OSND,"^",11)=""
- DO ^PSGNE3
- KILL PSGDRG,PSGORQF,^PS(53.45,PSJSYSP,1),^(2)
- SET (N,Q)=0
- +16 KILL PSJALLGY
- +17 ;If PSJMULDD >1 then the order has mutliple DD and it will flag ENDDC^PSGSICHK to display the OI name instead of DD name
- +18 SET PSJMULDD=0
- +19 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
- +20 SET PSJALLGY(+PSGDRG)=""
- SET PSJMULDD=PSJMULDD+1
- +21 ;D ENDDC^PSGSICHK(PSGP,+PSGDRG) Q:$D(PSGORQF)
- +22 ;D IN^PSJOCDS($G(PSGORD),"UD",+PSGDRG) Q:$D(PSGORQF)
- +23 ;D CONT^PSJOCDT Q:$D(PSGORQF)
- +24 if $PIECE(PSGDRG,U,2)=""
- SET $PIECE(PSGDRG,U,2)=1
- +25 SET N=N+1
- SET ^PS(53.45,PSJSYSP,2,N,0)=PSGDRG
- SET ^PS(53.45,PSJSYSP,2,"B",+PSGDRG,N)=""
- WRITE "."
- +26 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
- +27 SET PSGDRG=$ORDER(PSJALLGY(0))
- if '+PSGDRG
- QUIT
- +28 DO FULL^VALM1
- +29 DO ENDDC^PSGSICHK(PSGP,+PSGDRG)
- if $DATA(PSGORQF)
- QUIT
- +30 DO IN^PSJOCDS($GET(PSGORD),"UD",+PSGDRG)
- if $DATA(PSGORQF)
- QUIT
- +31 ;*309 - Remove second continue prompt
- +32 ;D CONT^PSJOCDT Q:$D(PSGORQF)
- +33 IF N
- SET ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_N_"^"_N
- +34 IF $GET(PSGORQF)
- WRITE !,?5,"...ORDER FOR ",PSGPDRGN," NOT ENTERED...",!
- QUIT
- +35 ;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..."
- +36 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..."
- +37 SET (PSGHSM,PSGSM)=""
- SET PSGPR=PSGOESPR
- DO ^PSGOETO
- SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
- +38 ; pharmacist label check, build label for order set only if auto verify turned on
- +39 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
- +40 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
- +41 ; ward clerk label check
- +42 IF PSJSYSL>0
- IF $PIECE(PSJSYSU,";",3)<3
- IF "12"[$PIECE(PSJSYSW0,"^",12)
- IF '(PSGOEAV)
- Begin DoDot:1
- +43 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"
- +44 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"
- +45 SET PSGTOL=2
- SET PSGUOW=DUZ
- SET PSGTOO=2
- SET DA=+PSGORD
- DO ENL^PSGVDS
- End DoDot:1
- +46 QUIT