PSJLMGUD.m

PSJLMGUD ;BIR/MLM-INITIALIZE UNIT DOSE ORDER FIELDS FOR DISPLAY ;05 Feb 99 / 9:46 AM

 ;;5.0; INPATIENT MEDICATIONS ;**25,58,85,116,110,111**;16 DEC 97

 ;

 ; Reference to ^PS(51.2 is supported by DBIA 2178

 ; Reference to ^PSDRUG( is supported by DBIA 2192 

 ; Reference to ^PS(55   is supported by DBIA 2191

 ; Reference to ES^ORX8 is supported by DBIA 3632

 ;

GETUD(DFN,PSGORD) ;

 ;

EN2 ;

 N %X,%Y,ND2,DO,DRGI,FD,FL,FQC,NF,ND,PRI,SD,SIG,ST,STD,X,Y,ESIG

 K GMRAL,P

 S NF=$S(PSGORD["U":0,PSGORD["A":0,PSGORD["O":0,1:1) I NF,$D(^PS(53.1,+PSGORD,0)),$P(^(0),"^",19),$D(^PS(55,DFN,5,$P(^(0),"^",19))),(+$P(^(0),"^",19)'=+$P(^(0),"^",25)) S PSGORD=+$P(^PS(53.1,+PSGORD,0),"^",19)_"U",NF=0

 S (FL,Y)="",$P(FL,"-",71)="",PSGOEEWF="^PS("_$S(NF:"53.1,",1:"55,"_DFN_",5,")_+PSGORD_","

 ; The naked reference on the line below refers to the full reference created by indirect reference to F, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55

 S ND=$G(@(PSGOEEWF_"0)")),ND2=$G(^(2)),PSGEB=$P($G(^(4)),"^",7),PSGOSI=$G(^(6)),SIG=$G(^(6.5)),DO=$G(^(.2)),PSGOINST=$G(^(.3)),ESIG=$P(DO,U,3),PSG14=$P($G(^(14,0)),"^",3)

 I PSG14 S PSGLRN=$G(@(PSGOEEWF_"14,"_PSG14_",0)"))

 S PSGOPD=+DO,PSGODO=$P(DO,U,2),PSGOPDN=$$OINAME^PSJLMUTL(+DO),X=$P(DO,U,4),PSGPRIO=$P("STAT^ASAP^ROUTINE^PREOP^TIME CRITICAL^DONE",U,$F("SARPTD",X)-1),PSJPRI=X

 S PSGOPR=$P(ND,"^",2),PSGOMR=$P(ND,"^",3),PSGOSM=$P(ND,"^",5),PSGOHSM=$P(ND,"^",6),(PSGOST,ST)=$P(ND,"^",7),STT=$P(ND,"^",9),PSGOMRN=$S('PSGOMR:"",1:$P($G(^PS(51.2,PSGOMR,0)),"^")) S:PSGOMRN="" PSGOMRN=PSGOMR

 S PSGLI=$P(ND,U,16),PSGOSCH=$P(ND2,"^"),(PSGOSD,SD)=$P(ND2,"^",2),(FD,PSGOFD)=$P(ND2,"^",4),(FQC,PSGS0XT)=$P(ND2,"^",6),(PSGOAT,PSGS0Y)=$P(ND2,"^",5)

 S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)

 ;I FQC="D",PSGOAT="" S PSGOAT=$E($P(SD,".",2)_"0000",1,4)

 S PRI=$S('PSGOPR:0,1:$P($G(^VA(200,PSGOPR,"PS")),"^",4)),DRGI=$S(PSGOPD'=+PSGOPD:0,1:+$G(^PSDRUG(+PSGOPD,"I"))) S:PRI PRI=DT'<PRI S:DRGI DRGI=DT'<DRGI

 S PSGOPRN=$S('PSGOPR:"",1:$P($G(^VA(200,PSGOPR,0)),"^")) S:PSGOPRN="" PSGOPRN=PSGOPR I PSGOSI]"" S PSGOSI=$$ENSET^PSGSICHK(PSGOSI)

 I $L($T(ES^ORX8)) N ESIG1 S ESIG1=$$ES^ORX8(+$P(ND,U,21)_";1") S:ESIG1=1 ESIG="ES"

 S PSGOPRN=PSGOPRN_$S(ESIG]"":" ["_$$LOW^XLFSTR(ESIG)_"]",1:"")

 S PSGEBN=$$ENNPN^PSGMI(PSGEB) S:$P(ND,U,27)="R" STT="R"

 S X=STT,PSGSTAT=$S(X="":"NOT FOUND",X="DE":"DISCONTINUED (EDIT)",X="DR":"DISCONTINUED (RENEWAL)",X="RE":"REINSTATED",1:$P(X_"^ACTIVE^DISCONTINUED^EXPIRED^HOLD^INCOMPLETE^NON-VERIFIED^PENDING^RENEWED^UNRELEASED","^",$F("ADEHINPRU",X)))

 ;

SET ;

 I STT="P" S (FD,SD,ST)=""

 S PSGOSTN=$$ENSTN^PSGMI(ST),(PSGOFDN,PSGOSDN)="" I SD S PSGOSDN=$$ENDD^PSGMI(SD)_"^"_$$ENDTC^PSGMI(SD)

 I FD S PSGOFDN=$$ENDD^PSGMI(FD)_"^"_$$ENDTC^PSGMI(FD)

 F X="PD","PDN","MR","MRN","ST","STN","SCH","SI","SD","SDN","FD","FDN","SM","HSM","PR","PRN","DO","AT" S @("PSG"_X)=@("PSGO"_X)

 K ^PS(53.45,PSJSYSP,1),^(2) S %X=PSGOEEWF_"3,",%Y="^PS(53.45,"_PSJSYSP_",1," D %XY^%RCR S %X=PSGOEEWF_"1,",%Y="^PS(53.45,"_PSJSYSP_",2," D %XY^%RCR

 S $P(^PS(53.45,PSJSYSP,2,0),"^",2)="53.4502P"

 K PSJNSS I $G(PSGSCH)'="" D  K PSJNSS

 . ;N PSGS0XT,PSGOES,Y S X=PSGSCH N PSGSCH S PSGSCH="" S:($G(VALMBCK)]"")!'$G(NSFF)!$G(PSJTUD) PSGOES=1 D ENOS^PSGS0

 . N PSGS0XTO,Y,PSGOES S X=PSGSCH S PSGS0XTO=PSGS0XT N PSGOSCH S PSGOSCH=PSGSCH S PSGSCH="",PSGOES=1

 . D ENOS^PSGS0 S:$G(X)="" PSGS0XT=PSGS0XTO S PSGSCH=$S($G(X)]""&($G(PSGS0XT)="D"):X,1:PSGOSCH)

 Q

 ;

FINISH ;

 I '$G(PSGS0XT),PSGOSCH]"" D  S $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT

 .N PSGOES,PSGS0Y S X=PSGOSCH,PSGOES=1 D ENOS^PSGS0

 S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10) I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")_" before it can be finished."

 I PSGOEFF W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," "

 I PSGOEFF#2 S F1=53.1,MSG=0,Y=$T(35),@("PSGFN(35)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(35),";",3) G:'PSGOEE DONE

 I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(PSGOPD,0) G:CHK DONE

 I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR

 I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD) N XQORM D EN^VALM("PSJ LM OE DISPLAY") G DONE ;D ENW^PSGOEEW

 ;

ACCEPT ;

 D UPD^PSGOEF1 G DONE

BYPASS ;

 S PSGCANFL=1 G DONE

 ;

EDIT ;    

 S PSGPDRG=PSGOPD,PSGPDRGN=PSGOPDN K PSGOEEND D ENF^PSGOEE I PSGCANFL=-1 D UPD^PSGOEF1

 ;

DONE ;

 K CHK,DA,DIE,DR,DRG,MSG,ORETURN,ORIFN,PSGEB,PSGEFN,PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2

 Q

 ;

 ;

31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1

32 ;;109^PSGOE8;PSGODO;PSGDO;102;PSGODO]""

33 ;;3^PSGOE8;PSGOMR;PSGMR;3;1

34 ;;7^PSGOE8;PSGOST;PSGST;7;0

35 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1

36 ;;39^PSGOE81;PSGOAT;PSGAT;39;0

37 ;;1^PSGOE82;PSGOPR;PSGPR;1;1

38 ;;8^PSGOE81;PSGOSI;PSGSI;8;0

39 ;;2^PSGOE82;;;2;0

310 ;;40^PSGOE82;;;40;0

311 ;;66^PSGOE82;;;66;1

312 ;;10^PSGOE81;PSGOSD;PSGSD;10;0

313 ;;25^PSGOE81;PSGOFD;PSGFD;25;0

314 ;;5^PSGOE82;PSGOSM;PSGSM;5;0

 ;

AH ;

 W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order.  Answer",!,"'NO' to edit this order now.  Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order."

 Q

PSJLMGUD  ;BIR/MLM-INITIALIZE UNIT DOSE ORDER FIELDS FOR DISPLAY ;05 Feb 99 / 9:46 AM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**25,58,85,116,110,111**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(51.2 is supported by DBIA 2178

 +4       ; Reference to ^PSDRUG( is supported by DBIA 2192 

 +5       ; Reference to ^PS(55   is supported by DBIA 2191

 +6       ; Reference to ES^ORX8 is supported by DBIA 3632

 +7       ;

GETUD(DFN,PSGORD) ;

 +1       ;

EN2       ;

 +1        NEW %X,%Y,ND2,DO,DRGI,FD,FL,FQC,NF,ND,PRI,SD,SIG,ST,STD,X,Y,ESIG

 +2        KILL GMRAL,P

 +3        SET NF=$SELECT(PSGORD["U":0,PSGORD["A":0,PSGORD["O":0,1:1)

           IF NF

               IF $DATA(^PS(53.1,+PSGORD,0))

                   IF $PIECE(^(0),"^",19)

                       IF $DATA(^PS(55,DFN,5,$PIECE(^(0),"^",19)))

                           IF (+$PIECE(^(0),"^",19)'=+$PIECE(^(0),"^",25))

                               SET PSGORD=+$PIECE(^PS(53.1,+PSGORD,0),"^",19)_"U"

                               SET NF=0

 +4        SET (FL,Y)=""

           SET $PIECE(FL,"-",71)=""

           SET PSGOEEWF="^PS("_$SELECT(NF:"53.1,",1:"55,"_DFN_",5,")_+PSGORD_","

 +5       ; The naked reference on the line below refers to the full reference created by indirect reference to F, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55

 +6        SET ND=$GET(@(PSGOEEWF_"0)"))

           SET ND2=$GET(^(2))

           SET PSGEB=$PIECE($GET(^(4)),"^",7)

           SET PSGOSI=$GET(^(6))

           SET SIG=$GET(^(6.5))

           SET DO=$GET(^(.2))

           SET PSGOINST=$GET(^(.3))

           SET ESIG=$PIECE(DO,U,3)

           SET PSG14=$PIECE($GET(^(14,0)),"^",3)

 +7        IF PSG14

               SET PSGLRN=$GET(@(PSGOEEWF_"14,"_PSG14_",0)"))

 +8        SET PSGOPD=+DO

           SET PSGODO=$PIECE(DO,U,2)

           SET PSGOPDN=$$OINAME^PSJLMUTL(+DO)

           SET X=$PIECE(DO,U,4)

           SET PSGPRIO=$PIECE("STAT^ASAP^ROUTINE^PREOP^TIME CRITICAL^DONE",U,$FIND("SARPTD",X)-1)

           SET PSJPRI=X

 +9        SET PSGOPR=$PIECE(ND,"^",2)

           SET PSGOMR=$PIECE(ND,"^",3)

           SET PSGOSM=$PIECE(ND,"^",5)

           SET PSGOHSM=$PIECE(ND,"^",6)

           SET (PSGOST,ST)=$PIECE(ND,"^",7)

           SET STT=$PIECE(ND,"^",9)

           SET PSGOMRN=$SELECT('PSGOMR:"",1:$PIECE($GET(^PS(51.2,PSGOMR,0)),"^"))

           IF PSGOMRN=""

               SET PSGOMRN=PSGOMR

 +10       SET PSGLI=$PIECE(ND,U,16)

           SET PSGOSCH=$PIECE(ND2,"^")

           SET (PSGOSD,SD)=$PIECE(ND2,"^",2)

           SET (FD,PSGOFD)=$PIECE(ND2,"^",4)

           SET (FQC,PSGS0XT)=$PIECE(ND2,"^",6)

           SET (PSGOAT,PSGS0Y)=$PIECE(ND2,"^",5)

 +11       SET PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)

 +12      ;I FQC="D",PSGOAT="" S PSGOAT=$E($P(SD,".",2)_"0000",1,4)

 +13       SET PRI=$SELECT('PSGOPR:0,1:$PIECE($GET(^VA(200,PSGOPR,"PS")),"^",4))

           SET DRGI=$SELECT(PSGOPD'=+PSGOPD:0,1:+$GET(^PSDRUG(+PSGOPD,"I")))

           IF PRI

               SET PRI=DT'<PRI

           IF DRGI

               SET DRGI=DT'<DRGI

 +14       SET PSGOPRN=$SELECT('PSGOPR:"",1:$PIECE($GET(^VA(200,PSGOPR,0)),"^"))

           IF PSGOPRN=""

               SET PSGOPRN=PSGOPR

           IF PSGOSI]""

               SET PSGOSI=$$ENSET^PSGSICHK(PSGOSI)

 +15       IF $LENGTH($TEXT(ES^ORX8))

               NEW ESIG1

               SET ESIG1=$$ES^ORX8(+$PIECE(ND,U,21)_";1")

               IF ESIG1=1

                   SET ESIG="ES"

 +16       SET PSGOPRN=PSGOPRN_$SELECT(ESIG]"":" ["_$$LOW^XLFSTR(ESIG)_"]",1:"")

 +17       SET PSGEBN=$$ENNPN^PSGMI(PSGEB)

           IF $PIECE(ND,U,27)="R"

               SET STT="R"

 +18       SET X=STT

           SET PSGSTAT=$SELECT(X="":"NOT FOUND",X="DE":"DISCONTINUED (EDIT)",X="DR":"DISCONTINUED (RENEWAL)",X="RE":"REINSTATED",1:$PIECE(X_"^ACTIVE^DISCONTINUED^EXPIRED^HOLD^INCOMPLETE^NON-VERIFIED^PENDING^RENEWED^UNRELEASED","^",$FIND("ADEHINPRU",X)))

 +19      ;

SET       ;

 +1        IF STT="P"

               SET (FD,SD,ST)=""

 +2        SET PSGOSTN=$$ENSTN^PSGMI(ST)

           SET (PSGOFDN,PSGOSDN)=""

           IF SD

               SET PSGOSDN=$$ENDD^PSGMI(SD)_"^"_$$ENDTC^PSGMI(SD)

 +3        IF FD

               SET PSGOFDN=$$ENDD^PSGMI(FD)_"^"_$$ENDTC^PSGMI(FD)

 +4        FOR X="PD","PDN","MR","MRN","ST","STN","SCH","SI","SD","SDN","FD","FDN","SM","HSM","PR","PRN","DO","AT"

               SET @("PSG"_X)=@("PSGO"_X)

 +5        KILL ^PS(53.45,PSJSYSP,1),^(2)

           SET %X=PSGOEEWF_"3,"

           SET %Y="^PS(53.45,"_PSJSYSP_",1,"

           DO %XY^%RCR

           SET %X=PSGOEEWF_"1,"

           SET %Y="^PS(53.45,"_PSJSYSP_",2,"

           DO %XY^%RCR

 +6        SET $PIECE(^PS(53.45,PSJSYSP,2,0),"^",2)="53.4502P"

 +7        KILL PSJNSS

           IF $GET(PSGSCH)'=""

               Begin DoDot:1

 +8       ;N PSGS0XT,PSGOES,Y S X=PSGSCH N PSGSCH S PSGSCH="" S:($G(VALMBCK)]"")!'$G(NSFF)!$G(PSJTUD) PSGOES=1 D ENOS^PSGS0

 +9                NEW PSGS0XTO,Y,PSGOES

                   SET X=PSGSCH

                   SET PSGS0XTO=PSGS0XT

                   NEW PSGOSCH

                   SET PSGOSCH=PSGSCH

                   SET PSGSCH=""

                   SET PSGOES=1

 +10               DO ENOS^PSGS0

                   IF $GET(X)=""

                       SET PSGS0XT=PSGS0XTO

                   SET PSGSCH=$SELECT($GET(X)]""&($GET(PSGS0XT)="D"):X,1:PSGOSCH)

               End DoDot:1

               KILL PSJNSS

 +11       QUIT 

 +12      ;

FINISH    ;

 +1        IF '$GET(PSGS0XT)

               IF PSGOSCH]""

                   Begin DoDot:1

 +2                    NEW PSGOES,PSGS0Y

                       SET X=PSGOSCH

                       SET PSGOES=1

                       DO ENOS^PSGS0

                   End DoDot:1

                   SET $PIECE(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT

 +3        SET PSGOEFF=PSGOSCH=""+('$ORDER(^PS(53.45,PSJSYSP,2,0))*10)

           IF PSGOEFF

               SET X=$SELECT(PSGOEFF#2:" a SCHEDULE",1:"")_$SELECT(PSGOEFF=11:" and",1:"")_$SELECT(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")_" before it can be finished."

 +4        IF PSGOEFF

               WRITE $CHAR(7),!!,"PLEASE NOTE: This order must have"

               FOR Q=1:1:$LENGTH(X," ")

                   SET Y=$PIECE(X," ",Q)

                   IF $LENGTH(Y)+$X>78

                       WRITE !

                   WRITE Y," "

 +5        IF PSGOEFF#2

               SET F1=53.1

               SET MSG=0

               SET Y=$TEXT(35)

               SET @("PSGFN(35)="_$PIECE(Y,";",7))

               SET PSGOEEF(+$PIECE(Y,";",3))=1

               SET (PSGOEE,PSGOEEF)=1

               WRITE !

               DO @$PIECE($TEXT(35),";",3)

               IF 'PSGOEE

                   GOTO DONE

 +6        IF PSGOEFF>9

               SET CHK=7

               DO ENDRG^PSGOEF1(PSGOPD,0)

               IF CHK

                   GOTO DONE

 +7        IF $GET(MSG)

               KILL DIR

               SET DIR(0)="E"

               WRITE !!

               DO ^DIR

 +8       ;D ENW^PSGOEEW

           IF PSGOEFF

               IF PSGST=""

                   DO GTST^PSGOE6(+PSGORD)

               NEW XQORM

               DO EN^VALM("PSJ LM OE DISPLAY")

               GOTO DONE

 +9       ;

ACCEPT    ;

 +1        DO UPD^PSGOEF1

           GOTO DONE

BYPASS    ;

 +1        SET PSGCANFL=1

           GOTO DONE

 +2       ;

EDIT      ;    

 +1        SET PSGPDRG=PSGOPD

           SET PSGPDRGN=PSGOPDN

           KILL PSGOEEND

           DO ENF^PSGOEE

           IF PSGCANFL=-1

               DO UPD^PSGOEF1

 +2       ;

DONE      ;

 +1        KILL CHK,DA,DIE,DR,DRG,MSG,ORETURN,ORIFN,PSGEB,PSGEFN,PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2

 +2        QUIT 

 +3       ;

 +4       ;

31        ;;101^PSGOE8;PSGOPD;PSGPD;101;1

32        ;;109^PSGOE8;PSGODO;PSGDO;102;PSGODO]""

33        ;;3^PSGOE8;PSGOMR;PSGMR;3;1

34        ;;7^PSGOE8;PSGOST;PSGST;7;0

35        ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1

36        ;;39^PSGOE81;PSGOAT;PSGAT;39;0

37        ;;1^PSGOE82;PSGOPR;PSGPR;1;1

38        ;;8^PSGOE81;PSGOSI;PSGSI;8;0

39        ;;2^PSGOE82;;;2;0

310       ;;40^PSGOE82;;;40;0

311       ;;66^PSGOE82;;;66;1

312       ;;10^PSGOE81;PSGOSD;PSGSD;10;0

313       ;;25^PSGOE81;PSGOFD;PSGFD;25;0

314       ;;5^PSGOE82;PSGOSM;PSGSM;5;0

 +1       ;

AH        ;

 +1        WRITE !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order.  Answer",!,"'NO' to edit this order now.  Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order."

 +2        QUIT