- PSJCOM ;BIR/CML - FINISH COMPLEX UNIT DOSE ORDERS ENTERED THROUGH OE/RR ;Jun 17, 2020@15:42:18
- ;;5.0;INPATIENT MEDICATIONS;**110,186,267,281,315,338,327,399,429**;16 DEC 97;Build 2
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ; Reference to ^VALM1 via DBIA 10116
- ; Reference to ^PS(55 via DBIA 2191
- ; Reference to ^%DTC via DBIA 10000
- ; Reference to ^%RCR via DBIA 10022
- ; Reference to ^DIR via DBIA 10026
- ; Reference to ^TIUEDIT via DBIA 2410
- ; Reference to ^TMP("PSODAOC",$J) via DBIA 6071
- ;
- UPD ;
- Q:'PSJCOM
- M ^TMP("PSJCOM",$J,+PSGORD)=^PS(53.1,+PSGORD)
- I PSGST="",(PSGSCH="NOW"!(PSGSCH="ONCE")) S PSGST="O"
- S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",9)="N",$P(^(0),"^",4)="U",$P(^(0),"^",7)=PSGST,$P(^TMP("PSJCOM",$J,+PSGORD,2),"^",2)=PSGSD,$P(^(2),"^",4)=PSGFD
- I $D(PSGSI),$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S ^TMP("PSJCOM",$J,+PSGORD,6)=PSGSI
- I $D(PSGSI),$P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S $P(^TMP("PSJCOM",$J,+PSGORD,6),U)=$P(PSGSI,U) I $P(PSGSI,U)="" S $P(^TMP("PSJCOM",$J,+PSGORD,6),U,2)=""
- S:$D(PSGSCH) $P(^TMP("PSJCOM",$J,+PSGORD,2),"^")=PSGSCH
- S:$D(PSGIND) $P(^TMP("PSJCOM",$J,+PSGORD,18),"^")=PSGIND ;*399-IND
- I PSGSM,PSGOHSM'=PSGHSM S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",5)=PSGSM,$P(^TMP("PSJCOM",$J,+PSGORD,0),"^",6)=PSGHSM K PSGOHSM
- W "."
- F Q=1,3 K @(PSGOEEWF_Q_")") S %X="^PS(53.45,"_PSJSYSP_","_$S(Q=1:2,1:1)_",",%Y=PSGOEEWF_Q_"," K @(PSGOEEWF_Q_")") D %XY^%RCR W "."
- ; Above code added to update file 53.1.
- S PSGOEEWF="^TMP(""PSJCOM"",$J,+PSGORD,"
- F Q=1,3 K @(PSGOEEWF_Q_")") S %X="^PS(53.45,"_PSJSYSP_","_$S(Q=1:2,1:1)_",",%Y=PSGOEEWF_Q_"," K @(PSGOEEWF_Q_")") D %XY^%RCR W "." ;MOU-0100-30945
- S PSGND=$G(^TMP("PSJCOM",$J,+PSGORD,0)),X=$P(PSGND,U,24)
- S PSJOWALL=+$G(^PS(55,PSGP,5.1))
- I $S(X="R":1,+$G(^PS(55,PSGP,5.1))>PSGDT:0,1:X'="E") S X=$G(^TMP("PSJCOM",$J,+PSGORD,2)) D ENWALL^PSGNE3(+$P(X,U,2),+$P(X,U,4),PSGP)
- S $P(^TMP("PSJCOM",$J,+PSGORD,.2),U,2)=PSGDO,$P(^TMP("PSJCOM",$J,+PSGORD,2),U,5)=PSGAT S:$G(PSGS0XT) $P(^(2),U,6)=PSGS0XT
- S:$G(PSGRF)]"" ^TMP("PSJCOM",$J,+PSGORD,2.1)=$G(PSGDUR)_U_$G(PSGRMVT)_U_$G(PSGRMV)_U_$G(PSGRF) K PSGDUR,PSGRMVT,PSGRMV,PSGRF ;315,P429[Added $G(PSGRF)]
- I 'PSGOEAV D NEWNVAL(PSGORD,$S(+PSJSYSU=3:22005,1:22000))
- I $D(^PS(53.45,DUZ,5,1,0)) D FILESI^PSJBCMA5(PSGP,PSGORD) N SIARRAY S SIARRAY="" D NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
- I PSGOEAV,+PSJSYSU=3 D VFY Q
- I PSGOEAV,$G(PSJRNF) D VFY
- Q
- VFY ; change status, move to 55, and change label record
- Q:'PSJCOM
- S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
- D SETOC^PSJNEWOC(PSGORD)
- I '$D(^TMP("PSJCOM",$J,+PSGORD)) M ^TMP("PSJCOM",$J,+PSGORD)=^PS(53.1,+PSGORD)
- NEW PSJDOSE,PSJDSFLG
- D DOSECHK^PSJDOSE
- I +$G(PSJDSFLG) D SETVAR^PSJDOSE W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1") I '$$CONT() W !,"...order was not verified..." D PAUSE^VALM1 D Q:'$G(PSJACEPT)
- . S PSGOEEF(109)=1
- . S PSJACEPT=0
- D DDCHK G:CHK DONE
- ;; START NCC REMEDIATION >> 327*RJS
- N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
- I CLOZFLG,'$G(^TMP("PSJCOM",$J,+PSGORD,"SAND")) D G:CHK DONE
- .S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DIR K DIR I $D(DIRUT) S CHK=1 Q ;G DONE:$G(CHK)
- .S (^TMP("PSJCOM",$J,+PSGORD,"SAND"),PSOSAND)=X
- ;; END NCC REMEDIATION >> 327*RJS
- W !,"...a few moments, please..."
- I PSGORD["P" D
- . S PSGORDP=PSGORD ;Used in ACTLOG to update activity log in ^TMP
- . I '$D(^TMP("PSJCOM2",$J,+PSGORD)) D Q
- .. NEW PSGX S PSGX=$G(^TMP("PSJCOM",$J,+PSGORD,2.5)),PSGRSD=$P(PSGX,U),PSGRFD=$P(PSGX,U,3)
- .. S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",9)="A" W "." ;D ^PSGOT
- . NEW PSGX S PSGX=$G(^TMP("PSJCOM2",$J,+PSGORD,2.5)),PSGRSD=$P(PSGX,U),PSGRFD=$P(PSGX,U,3)
- . S $P(^TMP("PSJCOM2",$J,+PSGORD,0),"^",9)="A" W "." ;D ^PSGOT
- D NEWNVAL(+PSGORD,(PSJSYSU*10+22000)) W "."
- S VND4=$S('$D(^TMP("PSJCOM2",$J,+PSGORD)):$G(^TMP("PSJCOM",$J,+PSGORD,4)),1:$G(^TMP("PSJCOM2",$J,+PSGORD,4)))
- I $G(PSGRSD) D
- . S PSGRSD=$$ENDTC^PSGMI(PSGRSD) D NEWNVAL(PSGORD,6090,"Requested Start Date",PSGRSD)
- . S PSGRFD=$$ENDTC^PSGMI(PSGRFD) D NEWNVAL(PSGORD,6090,"Requested Stop Date",PSGRFD)
- N DUR,DURORD S DURON=$S($G(ON)&($G(PSGORD)["U"):ON,$G(PSGORD):PSGORD,1:"") Q:'DURON D
- . S DUR=$S($P($G(PSGRDTX),U,2)]"":$P($G(PSGRDTX),U,2),1:$$GETDUR^PSJLIVMD(PSGP,+DURON,$S($G(DURON)["P":"P",$G(DURON)["V":"IV",1:5),1),1:"")
- I DUR]"" S $P(^TMP("PSJCOM2",$J,+PSGORD,2.5),"^",2)=DUR
- ;D:$D(PSGORDP) ACTLOG(PSGORDP,PSGP,PSGORD)
- K PSGRSD,PSGRFD,PSGALFN
- NEW X S X=0 I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S X=1
- I +PSJSYSU=3,PSGORD'["O",$S(X:0,'$P(VND4,"^",16):1,1:$P(VND4,"^",15)) ;D EN^PSGPEN(+PSGORD)
- S:'$P(VND4,U,+PSJSYSU=3+9) $P(VND4,U,+PSJSYSU=3+9)=+$P(VND4,U,+PSJSYSU=3+9)
- S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)&'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23) $P(VND4,"^",22)=""
- S $P(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT
- S:'$D(^TMP("PSJCOM2",$J,+PSGORD)) ^TMP("PSJCOM",$J,+PSGORD,4)=VND4 S:$D(^TMP("PSJCOM2",$J,+PSGORD)) ^TMP("PSJCOM2",$J,+PSGORD,4)=VND4
- W:'$D(PSJSPEED) ! W !,"ORDER VERIFIED.",!
- I CLOZFLG,$L($G(ANQDATA)) S ^TMP("PSJCOM",$J,+PSGORD,"ANQDATA")=ANQDATA
- I '$D(PSJSPEED) K DIR S DIR(0)="E" D ^DIR K DIR
- S VALMBCK="Q"
- S ^TMP("PSJCOM",$J)="A" S:$D(^TMP("PSJCOM2",$J,+PSGORD)) ^TMP("PSJCOM2",$J)="A"
- ;
- DONE ;
- W:CHK !!,"...order NOT verified..."
- I '$D(PSJSPEED),'CHK,+PSJSYSU=3,$G(PSJPRI)="D" D
- .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Progress Note",DIR("B")="No" D ^DIR
- .Q:Y="N"
- .D MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
- S VALMBCK="Q" K CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSJDOSE,PSJVAR,VND4,X,%X,%Y,Q,QQ Q
- ;
- DDCHK ; dispense drug check
- S DRGF=$S('$D(^TMP("PSJCOM2",$J,+PSGORD)):"^TMP(""PSJCOM"","_$J_","_+PSGORD_",",1:"^TMP(""PSJCOM2"","_$J_","_+PSGORD_","),CHK=$S('$O(@(DRGF_"1,0)")):7,1:0)
- S PSGPD=$G(@(DRGF_".2)"))
- S CHK=$S('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
- Q:CHK=0
- W $C(7),!!,"This order must have at least one valid, active dispense drug to be verified."
- ;
- CONT() ;
- NEW DIR,DIRUT,Y
- W ! K DIR,DIRUT
- S DIR(0)="Y",DIR("A")="Would you like to continue verifying the order",DIR("B")="No"
- D ^DIR
- Q Y
- ;
- NEWNVAL(PSGALORD,PSGALC,PSGFLD,PSGOLD) ;
- ;
- ;Where PSGALORD = PSGORD (Required)
- ; PSGALC = ACTIVITY CODE FROM #53.3 (Required)
- ; PSGFLD = FIELD THAT CHANGED (Free text, optional)
- ; PSGOLD = THE FIELDS OLD DATA VALUE (Free text, optional)
- ;
- ;N PSGALORD,PSGALC,PSGFLD,PSGOLD
- ;
- ; Create 0 node activity log for order if none exists, and get next entry number
- I '$D(^TMP("PSJCOM2",$J,+PSGALORD)) D Q
- . S QQ=$G(^TMP("PSJCOM",$J,+PSGALORD,"A",0)) S:QQ="" QQ="^53.1119D" F Q=$P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("N")=Q Q
- . ;Set up data to be held in activity log record
- . D NOW^%DTC S PSGDT=+$E(%,1,12)
- . I $L($G(PSGOLD))>170 S PSGOLD=$E(PSGOLD,1,167)_"..." ; Use of ... indicates old data field was greater than 170 characters
- . S Q=%_"^"_$S(PSGALC=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$S($D(PSGFLD):PSGFLD,1:"")_"^"_$S($D(PSGOLD):PSGOLD,1:"")
- . ; Create activity log entry
- . S ^TMP("PSJCOM",$J,+PSGALORD,"A",PSGAL("N"),0)=Q
- S QQ=$G(^TMP("PSJCOM2",$J,+PSGALORD,"A",0)) S:QQ="" QQ="^53.1119D" F Q=$P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("N")=Q Q
- ;Set up data to be held in activity log record
- D NOW^%DTC S PSGDT=+$E(%,1,12)
- I $L($G(PSGOLD))>170 S PSGOLD=$E(PSGOLD,1,167)_"..." ; Use of ... indicates old data field was greater than 170 characters
- S Q=%_"^"_$S(PSGALC=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$S($D(PSGFLD):PSGFLD,1:"")_"^"_$S($D(PSGOLD):PSGOLD,1:"")
- ; Create activity log entry
- S ^TMP("PSJCOM2",$J,+PSGALORD,"A",PSGAL("N"),0)=Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCOM 7870 printed Feb 18, 2025@23:32:53 Page 2
- PSJCOM ;BIR/CML - FINISH COMPLEX UNIT DOSE ORDERS ENTERED THROUGH OE/RR ;Jun 17, 2020@15:42:18
- +1 ;;5.0;INPATIENT MEDICATIONS;**110,186,267,281,315,338,327,399,429**;16 DEC 97;Build 2
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Reference to ^VALM1 via DBIA 10116
- +4 ; Reference to ^PS(55 via DBIA 2191
- +5 ; Reference to ^%DTC via DBIA 10000
- +6 ; Reference to ^%RCR via DBIA 10022
- +7 ; Reference to ^DIR via DBIA 10026
- +8 ; Reference to ^TIUEDIT via DBIA 2410
- +9 ; Reference to ^TMP("PSODAOC",$J) via DBIA 6071
- +10 ;
- UPD ;
- +1 if 'PSJCOM
- QUIT
- +2 MERGE ^TMP("PSJCOM",$JOB,+PSGORD)=^PS(53.1,+PSGORD)
- +3 IF PSGST=""
- IF (PSGSCH="NOW"!(PSGSCH="ONCE"))
- SET PSGST="O"
- +4 SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,0),"^",9)="N"
- SET $PIECE(^(0),"^",4)="U"
- SET $PIECE(^(0),"^",7)=PSGST
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,2),"^",2)=PSGSD
- SET $PIECE(^(2),"^",4)=PSGFD
- +5 IF $DATA(PSGSI)
- IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)'="R"
- SET ^TMP("PSJCOM",$JOB,+PSGORD,6)=PSGSI
- +6 IF $DATA(PSGSI)
- IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R"
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,6),U)=$PIECE(PSGSI,U)
- IF $PIECE(PSGSI,U)=""
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,6),U,2)=""
- +7 if $DATA(PSGSCH)
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,2),"^")=PSGSCH
- +8 ;*399-IND
- if $DATA(PSGIND)
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,18),"^")=PSGIND
- +9 IF PSGSM
- IF PSGOHSM'=PSGHSM
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,0),"^",5)=PSGSM
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,0),"^",6)=PSGHSM
- KILL PSGOHSM
- +10 WRITE "."
- +11 FOR Q=1,3
- KILL @(PSGOEEWF_Q_")")
- SET %X="^PS(53.45,"_PSJSYSP_","_$SELECT(Q=1:2,1:1)_","
- SET %Y=PSGOEEWF_Q_","
- KILL @(PSGOEEWF_Q_")")
- DO %XY^%RCR
- WRITE "."
- +12 ; Above code added to update file 53.1.
- +13 SET PSGOEEWF="^TMP(""PSJCOM"",$J,+PSGORD,"
- +14 ;MOU-0100-30945
- FOR Q=1,3
- KILL @(PSGOEEWF_Q_")")
- SET %X="^PS(53.45,"_PSJSYSP_","_$SELECT(Q=1:2,1:1)_","
- SET %Y=PSGOEEWF_Q_","
- KILL @(PSGOEEWF_Q_")")
- DO %XY^%RCR
- WRITE "."
- +15 SET PSGND=$GET(^TMP("PSJCOM",$JOB,+PSGORD,0))
- SET X=$PIECE(PSGND,U,24)
- +16 SET PSJOWALL=+$GET(^PS(55,PSGP,5.1))
- +17 IF $SELECT(X="R":1,+$GET(^PS(55,PSGP,5.1))>PSGDT:0,1:X'="E")
- SET X=$GET(^TMP("PSJCOM",$JOB,+PSGORD,2))
- DO ENWALL^PSGNE3(+$PIECE(X,U,2),+$PIECE(X,U,4),PSGP)
- +18 SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,.2),U,2)=PSGDO
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,2),U,5)=PSGAT
- if $GET(PSGS0XT)
- SET $PIECE(^(2),U,6)=PSGS0XT
- +19 ;315,P429[Added $G(PSGRF)]
- if $GET(PSGRF)]""
- SET ^TMP("PSJCOM",$JOB,+PSGORD,2.1)=$GET(PSGDUR)_U_$GET(PSGRMVT)_U_$GET(PSGRMV)_U_$GET(PSGRF)
- KILL PSGDUR,PSGRMVT,PSGRMV,PSGRF
- +20 IF 'PSGOEAV
- DO NEWNVAL(PSGORD,$SELECT(+PSJSYSU=3:22005,1:22000))
- +21 IF $DATA(^PS(53.45,DUZ,5,1,0))
- DO FILESI^PSJBCMA5(PSGP,PSGORD)
- NEW SIARRAY
- SET SIARRAY=""
- DO NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
- +22 IF PSGOEAV
- IF +PSJSYSU=3
- DO VFY
- QUIT
- +23 IF PSGOEAV
- IF $GET(PSJRNF)
- DO VFY
- +24 QUIT
- VFY ; change status, move to 55, and change label record
- +1 if 'PSJCOM
- QUIT
- +2 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSGORD
- +3 DO SETOC^PSJNEWOC(PSGORD)
- +4 IF '$DATA(^TMP("PSJCOM",$JOB,+PSGORD))
- MERGE ^TMP("PSJCOM",$JOB,+PSGORD)=^PS(53.1,+PSGORD)
- +5 NEW PSJDOSE,PSJDSFLG
- +6 DO DOSECHK^PSJDOSE
- +7 IF +$GET(PSJDSFLG)
- DO SETVAR^PSJDOSE
- WRITE !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1")
- IF '$$CONT()
- WRITE !,"...order was not verified..."
- DO PAUSE^VALM1
- Begin DoDot:1
- +8 SET PSGOEEF(109)=1
- +9 SET PSJACEPT=0
- End DoDot:1
- if '$GET(PSJACEPT)
- QUIT
- +10 DO DDCHK
- if CHK
- GOTO DONE
- +11 ;; START NCC REMEDIATION >> 327*RJS
- +12 NEW CLOZFLG
- SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
- +13 IF CLOZFLG
- IF '$GET(^TMP("PSJCOM",$JOB,+PSGORD,"SAND"))
- Begin DoDot:1
- +14 ;G DONE:$G(CHK)
- SET DIR(0)="N^12.5:3000:1"
- SET DIR("A")="CLOZAPINE dosage (mg/day) ? "
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET CHK=1
- QUIT
- +15 SET (^TMP("PSJCOM",$JOB,+PSGORD,"SAND"),PSOSAND)=X
- End DoDot:1
- if CHK
- GOTO DONE
- +16 ;; END NCC REMEDIATION >> 327*RJS
- +17 WRITE !,"...a few moments, please..."
- +18 IF PSGORD["P"
- Begin DoDot:1
- +19 ;Used in ACTLOG to update activity log in ^TMP
- SET PSGORDP=PSGORD
- +20 IF '$DATA(^TMP("PSJCOM2",$JOB,+PSGORD))
- Begin DoDot:2
- +21 NEW PSGX
- SET PSGX=$GET(^TMP("PSJCOM",$JOB,+PSGORD,2.5))
- SET PSGRSD=$PIECE(PSGX,U)
- SET PSGRFD=$PIECE(PSGX,U,3)
- +22 ;D ^PSGOT
- SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,0),"^",9)="A"
- WRITE "."
- End DoDot:2
- QUIT
- +23 NEW PSGX
- SET PSGX=$GET(^TMP("PSJCOM2",$JOB,+PSGORD,2.5))
- SET PSGRSD=$PIECE(PSGX,U)
- SET PSGRFD=$PIECE(PSGX,U,3)
- +24 ;D ^PSGOT
- SET $PIECE(^TMP("PSJCOM2",$JOB,+PSGORD,0),"^",9)="A"
- WRITE "."
- End DoDot:1
- +25 DO NEWNVAL(+PSGORD,(PSJSYSU*10+22000))
- WRITE "."
- +26 SET VND4=$SELECT('$DATA(^TMP("PSJCOM2",$JOB,+PSGORD)):$GET(^TMP("PSJCOM",$JOB,+PSGORD,4)),1:$GET(^TMP("PSJCOM2",$JOB,+PSGORD,4)))
- +27 IF $GET(PSGRSD)
- Begin DoDot:1
- +28 SET PSGRSD=$$ENDTC^PSGMI(PSGRSD)
- DO NEWNVAL(PSGORD,6090,"Requested Start Date",PSGRSD)
- +29 SET PSGRFD=$$ENDTC^PSGMI(PSGRFD)
- DO NEWNVAL(PSGORD,6090,"Requested Stop Date",PSGRFD)
- End DoDot:1
- +30 NEW DUR,DURORD
- SET DURON=$SELECT($GET(ON)&($GET(PSGORD)["U"):ON,$GET(PSGORD):PSGORD,1:"")
- if 'DURON
- QUIT
- Begin DoDot:1
- +31 SET DUR=$SELECT($PIECE($GET(PSGRDTX),U,2)]"":$PIECE($GET(PSGRDTX),U,2),1:$$GETDUR^PSJLIVMD(PSGP,+DURON,$SELECT($GET(DURON)["P":"P",$GET(DURON)["V":"IV",1:5),1),1:"")
- End DoDot:1
- +32 IF DUR]""
- SET $PIECE(^TMP("PSJCOM2",$JOB,+PSGORD,2.5),"^",2)=DUR
- +33 ;D:$D(PSGORDP) ACTLOG(PSGORDP,PSGP,PSGORD)
- +34 KILL PSGRSD,PSGRFD,PSGALFN
- +35 NEW X
- SET X=0
- IF $GET(PSGONF)
- IF (+$GET(PSGODDD(1))'<+$GET(PSGONF))
- SET X=1
- +36 ;D EN^PSGPEN(+PSGORD)
- IF +PSJSYSU=3
- IF PSGORD'["O"
- IF $SELECT(X:0,'$PIECE(VND4,"^",16):1,1:$PIECE(VND4,"^",15))
- +37 if '$PIECE(VND4,U,+PSJSYSU=3+9)
- SET $PIECE(VND4,U,+PSJSYSU=3+9)=+$PIECE(VND4,U,+PSJSYSU=3+9)
- +38 if $PIECE(VND4,"^",15)&'$PIECE(VND4,"^",16)
- SET $PIECE(VND4,"^",15)=""
- if $PIECE(VND4,"^",18)&'$PIECE(VND4,"^",19)
- SET $PIECE(VND4,"^",18)=""
- if $PIECE(VND4,"^",22)&'$PIECE(VND4,"^",23)
- SET $PIECE(VND4,"^",22)=""
- +39 SET $PIECE(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT
- +40 if '$DATA(^TMP("PSJCOM2",$JOB,+PSGORD))
- SET ^TMP("PSJCOM",$JOB,+PSGORD,4)=VND4
- if $DATA(^TMP("PSJCOM2",$JOB,+PSGORD))
- SET ^TMP("PSJCOM2",$JOB,+PSGORD,4)=VND4
- +41 if '$DATA(PSJSPEED)
- WRITE !
- WRITE !,"ORDER VERIFIED.",!
- +42 IF CLOZFLG
- IF $LENGTH($GET(ANQDATA))
- SET ^TMP("PSJCOM",$JOB,+PSGORD,"ANQDATA")=ANQDATA
- +43 IF '$DATA(PSJSPEED)
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +44 SET VALMBCK="Q"
- +45 SET ^TMP("PSJCOM",$JOB)="A"
- if $DATA(^TMP("PSJCOM2",$JOB,+PSGORD))
- SET ^TMP("PSJCOM2",$JOB)="A"
- +46 ;
- DONE ;
- +1 if CHK
- WRITE !!,"...order NOT verified..."
- +2 IF '$DATA(PSJSPEED)
- IF 'CHK
- IF +PSJSYSU=3
- IF $GET(PSJPRI)="D"
- Begin DoDot:1
- +3 NEW DIR
- WRITE !
- SET DIR(0)="S^Y:Yes;N:No"
- SET DIR("A")="Do you want to enter a Progress Note"
- SET DIR("B")="No"
- DO ^DIR
- +4 if Y="N"
- QUIT
- +5 DO MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
- End DoDot:1
- +6 SET VALMBCK="Q"
- KILL CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSJDOSE,PSJVAR,VND4,X,%X,%Y,Q,QQ
- QUIT
- +7 ;
- DDCHK ; dispense drug check
- +1 SET DRGF=$SELECT('$DATA(^TMP("PSJCOM2",$JOB,+PSGORD)):"^TMP(""PSJCOM"","_$JOB_","_+PSGORD_",",1:"^TMP(""PSJCOM2"","_$JOB_","_+PSGORD_",")
- SET CHK=$SELECT('$ORDER(@(DRGF_"1,0)")):7,1:0)
- +2 SET PSGPD=$GET(@(DRGF_".2)"))
- +3 SET CHK=$SELECT('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
- +4 if CHK=0
- QUIT
- +5 WRITE $CHAR(7),!!,"This order must have at least one valid, active dispense drug to be verified."
- +6 ;
- CONT() ;
- +1 NEW DIR,DIRUT,Y
- +2 WRITE !
- KILL DIR,DIRUT
- +3 SET DIR(0)="Y"
- SET DIR("A")="Would you like to continue verifying the order"
- SET DIR("B")="No"
- +4 DO ^DIR
- +5 QUIT Y
- +6 ;
- NEWNVAL(PSGALORD,PSGALC,PSGFLD,PSGOLD) ;
- +1 ;
- +2 ;Where PSGALORD = PSGORD (Required)
- +3 ; PSGALC = ACTIVITY CODE FROM #53.3 (Required)
- +4 ; PSGFLD = FIELD THAT CHANGED (Free text, optional)
- +5 ; PSGOLD = THE FIELDS OLD DATA VALUE (Free text, optional)
- +6 ;
- +7 ;N PSGALORD,PSGALC,PSGFLD,PSGOLD
- +8 ;
- +9 ; Create 0 node activity log for order if none exists, and get next entry number
- +10 IF '$DATA(^TMP("PSJCOM2",$JOB,+PSGALORD))
- Begin DoDot:1
- +11 SET QQ=$GET(^TMP("PSJCOM",$JOB,+PSGALORD,"A",0))
- if QQ=""
- SET QQ="^53.1119D"
- FOR Q=$PIECE(QQ,"^",3)+1:1
- IF '$DATA(^(Q))
- SET $PIECE(QQ,"^",3,4)=Q_"^"_Q
- SET ^(0)=QQ
- SET PSGAL("N")=Q
- QUIT
- +12 ;Set up data to be held in activity log record
- +13 DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- +14 ; Use of ... indicates old data field was greater than 170 characters
- IF $LENGTH($GET(PSGOLD))>170
- SET PSGOLD=$EXTRACT(PSGOLD,1,167)_"..."
- +15 SET Q=%_"^"_$SELECT(PSGALC=6010:"AUTO CANCEL",$DATA(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$SELECT($DATA(PSGFLD):PSGFLD,1:"")_"^"_$SELECT($DATA(PSGOLD):PSGOLD,1:"")
- +16 ; Create activity log entry
- +17 SET ^TMP("PSJCOM",$JOB,+PSGALORD,"A",PSGAL("N"),0)=Q
- End DoDot:1
- QUIT
- +18 SET QQ=$GET(^TMP("PSJCOM2",$JOB,+PSGALORD,"A",0))
- if QQ=""
- SET QQ="^53.1119D"
- FOR Q=$PIECE(QQ,"^",3)+1:1
- IF '$DATA(^(Q))
- SET $PIECE(QQ,"^",3,4)=Q_"^"_Q
- SET ^(0)=QQ
- SET PSGAL("N")=Q
- QUIT
- +19 ;Set up data to be held in activity log record
- +20 DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- +21 ; Use of ... indicates old data field was greater than 170 characters
- IF $LENGTH($GET(PSGOLD))>170
- SET PSGOLD=$EXTRACT(PSGOLD,1,167)_"..."
- +22 SET Q=%_"^"_$SELECT(PSGALC=6010:"AUTO CANCEL",$DATA(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$SELECT($DATA(PSGFLD):PSGFLD,1:"")_"^"_$SELECT($DATA(PSGOLD):PSGOLD,1:"")
- +23 ; Create activity log entry
- +24 SET ^TMP("PSJCOM2",$JOB,+PSGALORD,"A",PSGAL("N"),0)=Q
- +25 QUIT