Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGOES

PSGOES.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PS(50.7 is supported by DBIA 2180.
  1. ; Reference to ^PS(55 is supported by DBIA 2191.
  1. ; Reference to ^PSDRUG( is supported by DBIA 2192.
  1. ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
  1. ;
  1. NEW PSJNOOSV
  1. 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
  1. I '$D(^PS(53.2,+Y,2)) W " Invalid Order Set" Q
  1. I $P(PSJSYSU,";",2) S PSGOESPR=DUZ
  1. E D G:Y'>0 DONE
  1. .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
  1. .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
  1. .S PSGOESPR=+Y S:$P($G(^PS(55,PSGP,5.1)),"^",2)'=+Y $P(^(5.1),"^",2)=+Y
  1. S (PSJNOO,PSJNOOSV)=$$ENNOO^PSJUTL5("N")
  1. I $G(PSJNOO)<0 W !,$C(7),"...order set not entered..." G DONE
  1. 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
  1. ;
  1. DONE ;
  1. K PSJNOON,PSJNOO,PSJNOOSV
  1. S X="S.X" K %DT,N,OSND,PSGOESDA,PSGDDRG,PSGOESI,PSGOES,PSGOEOS,PSGOESN,PSGOESPR,PSGQUIT,PSGX,SDT,STDAY,X1,X2 Q
  1. ;
  1. GND ;
  1. NEW PSJOCDS,PSJALLGY,PSJMULDD,PSJOLDNM,PSGRF,ND2P1
  1. K PSGOEE,PSGSCH,PSGORD
  1. K ^TMP("PSODAOC",$J)
  1. S:'$D(PSJNOO) PSJNOO=$G(PSJNOOSV)
  1. S (PSGPDRG,PSGX)=+OSND,PSGPDRGN=$P($G(^PS(50.7,PSGPDRG,0)),"^") S:PSGPDRGN="" PSGPDRGN=PSGPDRG
  1. S PSGRF=$P($G(^PS(50.7,PSGPDRG,4),0),U,1)
  1. W !!,"...entering ",$S(PSGPDRGN'=PSGPDRG:PSGPDRGN,1:"** UNKNOWN **"),"..."
  1. K Y,DIRUT D END^PSGSICHK S PSGQUIT=$D(DIRUT) Q:$G(Y)<0
  1. S PSGNEDFD=$P(OSND,"^",2,5),PSGMR=$P(OSND,"^",3),PSGST=$P(OSND,"^",4),PSGDO=$P(OSND,"^",9),PSGMRN=$$ENMRN^PSGMI(PSGMR)
  1. ;PSJ*5*256
  1. I '+$P(OSND,"^",5) S PSJOLDNM("ORD_SCHD")=$P(OSND,"^",5) I $$CHKSCHD^PSJMISC2(.PSJOLDNM) Q
  1. S:PSGMRN="" PSGMRN=PSGMR D NOW^%DTC S PSGDT=+$E(%,1,12) I PSGST="OC" S PSGSCH="ON CALL",(PSGS0XT,PSGS0Y)=""
  1. 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)=""
  1. S (PSGNESD,PSGNEFD)="" W "." I $P(OSND,"^",11)]"" S %DT="T",X=$P(OSND,"^",11) D ^%DT S PSGNESD=Y D ENFD^PSGNE3(PSGDT)
  1. D:$P(OSND,"^",11)="" ^PSGNE3 K PSGDRG,PSGORQF,^PS(53.45,PSJSYSP,1),^(2) S (N,Q)=0
  1. K PSJALLGY
  1. ;If PSJMULDD >1 then the order has mutliple DD and it will flag ENDDC^PSGSICHK to display the OI name instead of DD name
  1. S PSJMULDD=0
  1. F S Q=$O(^PS(53.2,PSGOESDA,2,PSGOESN,2,Q)) Q:'Q!$D(PSGORQF) S PSGDRG=$G(^(Q,0)) I PSGDRG D
  1. .S PSJALLGY(+PSGDRG)="",PSJMULDD=PSJMULDD+1
  1. .;D ENDDC^PSGSICHK(PSGP,+PSGDRG) Q:$D(PSGORQF)
  1. .;D IN^PSJOCDS($G(PSGORD),"UD",+PSGDRG) Q:$D(PSGORQF)
  1. .;D CONT^PSJOCDT Q:$D(PSGORQF)
  1. .S:$P(PSGDRG,U,2)="" $P(PSGDRG,U,2)=1
  1. .S N=N+1,^PS(53.45,PSJSYSP,2,N,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",+PSGDRG,N)="" W "."
  1. .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..."
  1. S PSGDRG=$O(PSJALLGY(0)) Q:'+PSGDRG
  1. D FULL^VALM1
  1. D ENDDC^PSGSICHK(PSGP,+PSGDRG) Q:$D(PSGORQF)
  1. D IN^PSJOCDS($G(PSGORD),"UD",+PSGDRG) Q:$D(PSGORQF)
  1. ;*309 - Remove second continue prompt
  1. ;D CONT^PSJOCDT Q:$D(PSGORQF)
  1. I N S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_N_"^"_N
  1. I $G(PSGORQF) W !,?5,"...ORDER FOR ",PSGPDRGN," NOT ENTERED...",! Q
  1. ;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..."
  1. 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..."
  1. S (PSGHSM,PSGSM)="",PSGPR=PSGOESPR D ^PSGOETO S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
  1. ; pharmacist label check, build label for order set only if auto verify turned on
  1. I PSJSYSL>0,(PSGOEAV),($P($G(^PS(55,PSGP,5,$S($D(DA):DA,1:+PSGORD),0)),U,9)="A") D
  1. .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
  1. ; ward clerk label check
  1. I PSJSYSL>0,$P(PSJSYSU,";",3)<3,"12"[$P(PSJSYSW0,"^",12),'(PSGOEAV) D
  1. .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"
  1. .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"
  1. .S PSGTOL=2,PSGUOW=DUZ,PSGTOO=2,DA=+PSGORD D ENL^PSGVDS
  1. Q