Routine: PSGOES

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

--- 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

PSGOES.m