- PSOVER1 ;BHAM ISC/SAB - verify one rx ;29-May-2012 15:17;PLS
- ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,1002,1004,1007,1011,202,207,148,243,268,281,1015**;DEC 1997;Build 62
- ;External reference ^PSDRUG( supported by DBIA 221
- ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- ;External reference ^PS(55 supported by DBIA 2228
- ;External reference to PSSORPH is supported by DBIA 3234
- ;External references to ^ORRDI1 supported by DBIA 4659
- ;External reference ^XTMP("ORRDI" supported by DBIA 4660
- ; Modified - IHS/CIA/PLS - 01/29/04 - Line CHANGE+3
- ; IHS/CIA/PLS - 12/16/04 - Lines REDO+1, EDIT+1, new EP (CHKPRV)
- ; IHS/MSC/PLS - 07/10/08 - Changed references to PSOVER array to PSOVERA
- ; IHS/MSC/PLS - 06/30/11 - Lines REDO+5 and new NVA EP to match patch 202
- REDO ;
- S (DRG,PSODRUG("NAME"))=$P(^PSDRUG(+$P(^PSRX(PSONV,0),"^",6),0),"^"),PSODRUG("VA CLASS")=$P(^(0),"^",2)
- I '$D(PSODFN) S PSODFN=$P(^PSRX(PSONV,0),"^",2)
- ; IHS/CIA/PLS - 12/16/04 - Added check and message.
- I '$$CHKPRV(PSONV) D Q
- .W !,"This prescription lacks an ordering provider and can't",!,"be processed until one is selected!"
- S (STA,DNM)="",PSDPSTOP=0,$P(PSONULN,"-",79)="-" F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM="" K PSZZZDUP I $P(PSOSD(STA,DNM),"^",2)<10 D
- .;IHS/MSC/PLS - 06/30/2011
- .I STA="ZNONVA" D NVA Q
- .;I PSODRUG("NAME")=$P(DNM,"^")&(PSONV'=$P(PSOSD(STA,DNM),"^")) S PSZZZDUP=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR D DUP^PSODRDUP S PSDTSTOP=1
- .I PSODRUG("NAME")=$P(DNM,"^")&(PSONV'=$P(PSOSD(STA,DNM),"^")) S PSZZZDUP=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR S PSDTSTOP=1
- .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR D CLS^PSODRDUP S PSDTSTOP=1
- .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")=12,$D(^PS(52.4,$P(PSOSD(STA,DNM),"^"),0)) S DA=$P(PSOSD(STA,DNM),"^"),DIK="^PS(52.4," D ^DIK K DIK
- .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")'=12 S PSZZQUIT=1
- K MSG I $G(PSZZQUIT),$G(PSVFLAG) K PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q
- D REMOTE
- K PSODRUG,PSODFN,PSZZZDUP,DNM,PSZZQUIT
- ALLR ;Allergy check
- S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL I $G(PSZZQUIT) K MSG,PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q
- G:'$P($G(^PSRX(PSONV,3)),"^",6) EDIT
- I '$G(PSDTSTOP) K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) K PSDTSTOP G OUT
- W !!,"A Drug-Allergy Reaction exists for this medication!",!!,"***SIGNIFICANT*** Allergy Reaction"
- W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(PSONV,0)),"^",6),0)),"^")
- I $O(^PSRX(PSONV,"DAI",0)) W !?6,"Ingredients: " D
- .F PSPPP=0:0 S PSPPP=$O(^PSRX(PSONV,"DAI",PSPPP)) Q:'PSPPP I $G(^(PSPPP,0))'="" W:$X+$L($G(^PSRX(PSONV,"DAI",PSPPP,0)))+2>IOM !?19 W $G(^PSRX(PSONV,"DAI",PSPPP,0))_", "
- W ! K DIR,PSPPP S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to intervene?" D ^DIR K DIR I X["^"!($D(DTOUT))!($D(DUOUT)) K PSDTSTOP G OUT
- I Y S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV)
- EDIT I $G(PKI1)=2 D DCV1^PSOPKIV1 G OUT
- ; IHS/CIA/PLS - 12/16/04 - Corrected misspelling
- ;K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to procede with verification"
- K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to proceed with verification"
- D ^DIR K DIR I Y="Y",$G(PSOACT)]"" S VALMBCK="R" G OUT
- I $D(DIRUT),$G(PSOCLK) S PSOCQ=1 G OUT
- I $D(DIRUT),$G(PSOACT)]"" S VALMBCK="R" G OUT
- G VERIFY:Y="N",PROF:Y="P",OUT:"YNP"'[$E(Y)
- CHANGE S DA=PSONV,(PSRX1,PSRX2)=$P(^PSRX(PSONV,0),"^",6)
- S DEA1=1,DEA2=0,PSDOLD=+DA,DIE="^PSRX(",DR="3;7;8;9;4;5;12;1;22;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_$S($P(PSOPAR,"^",15):"10.6",1:"")_";@2" D ^DIE
- ;I PSRX1'=PSRX2,DEA1'=DEA2 S DR="6////"_PSRX1 D ^DIE
- ;IHS/CIA/PLS - 01/29/04 - Prompt for IHS fields
- S DR="27;9999999.06;9999999.02;17;28;29;9999999.14" D ^DIE
- D EXPIRE K DIE,DR,DEA1,DEA2,P(5),PSRX1,PSRX2
- K PSD(PSDOLD) S PSDNEW=$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^")_"^"_PSONV,PSD(PSDNEW)=PSONV_"^*^1^"_$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^",2)
- S DA=PSONV D ^PSORXPR
- G EDIT:PSDNEW=PSDOLD,REDO
- PROF I '$D(PSOSD) W !,$C(7),"This patient has no other prescriptions on file",!! G EDIT Q
- D ^PSODSPL G EDIT Q
- ;
- EXPIRE S RX0=^PSRX(DA,0),X1=$P($P(RX0,"^",13),"."),X2=$P(RX0,"^",9)+1*$P(RX0,"^",8),X2=$S($P(RX0,"^",8)=X2:X2,X2<181:184,X2=360:366,1:X2),X=X1 D:X1&X2 C^%DTC
- K ^PS(55,PSDFN,"P","A",+$P(^PSRX(DA,2),"^",6),DA) S ^PS(55,PSDFN,"P","A",X,DA)="",$P(^PSRX(DA,2),"^",6)=X,$P(^PS(52.4,DA,0),"^",7)=X Q
- VERIFY G:'$P(PSOPAR,"^",2) VERY
- S DIR("A")="VERIFY FOR "_PSONAM_" ? (Y/N/Delete/Quit): ",DIR("B")="Y",DIR(0)="SA^Y:YES;N:NO;D:DELETE;Q:QUIT"
- S DIR("?",1)="Enter Y (or return) to verify this prescription",DIR("?",2)="N to leave this prescription non-verified and to end this session of verification",DIR("?")="D to delete this prescription"
- D ^DIR K DIR G OUT:Y="N",QUIT:"Q^"[$E(Y),DELETE:Y="D"
- VERY I $G(PKI1)=1 D REA^PSOPKIV1 G:'$D(PKIR) VERIFY
- K ^PSRX(PSONV,"DAI") S $P(^PSRX(PSONV,3),"^",6)=""
- K ^PSRX(PSONV,"DRI"),SPFL
- I '$O(^PSRX(PSONV,6,0)) D I $D(DUOUT)!($D(DTOUT)) W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" not Verified!!",! H 2 G OUT
- .W !!,"Dosing Instructions Missing. Please add!",!
- .I $P($G(^PSRX(PSONV,"SIG")),"^")]"",'$P($G(^("SIG")),"^",2) W "SIG: "_$P(^PSRX(PSONV,"SIG"),"^"),!
- .I $P($G(^PSRX(PSONV,"SIG")),"^",2),$O(^PSRX(PSONV,"SIG1",0)) D K I
- ..W "SIG: " F I=0:0 S I=$O(^PSRX(PSONV,"SIG1",I)) Q:'I W ^PSRX(PSONV,"SIG1",I,0),!
- .S DA=PSONV,PSOVER=1 K DIR,DIRUT,DUOUT,DTOUT
- .S PSODRUG("IEN")=$P(^PSRX(DA,0),"^",6),PSODFN=$P(^(0),"^",2),PSORXED("IRXN")=DA,PSODRUG("OI")=$P(^PSRX(DA,"OR1"),"^")
- .D DOSE^PSSORPH(.DOSE,PSODRUG("IEN"),"O",PSODFN),^PSOORED3
- .K PSODFN,PSODRUG("IEN"),DOSE,PSOVER
- .I '$G(ENT) S DUOUT=1
- .Q:$D(DUOUT)!($D(DTOUT))
- .K DIR,DIRUT,DUOUT,DTOUT S DIE=52,DR=114 D ^DIE K DIE,DR,DTOUT
- .I X'="" D SIG^PSOHELP D:$G(INS1)]"" EN^DDIOL($E(INS1,2,9999999)) S PSORXED("SIG",1)=$E(INS1,2,9999999)
- .D EN^PSOFSIG(.PSORXED,1),UDSIG^PSOORED3 H 2
- S DA=PSONV,$P(^PSRX(DA,2),"^",10)=DUZ I $P(^PSRX(DA,2),"^",2)>DT,$P(PSOPAR,"^",6) S (SPFL1,PSOVER)="",PSORX("FILL DATE")=$P(^(2),"^",2),RXF=0 D UPSUS S PSTRIVER=1 D SUS^PSORXL K PSORX("FILL DATE"),PSTRIVER G KILL
- ; IHS/MSC/PLS - 07/10/08
- ;S PSOVER(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
- S PSOVERA(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
- I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(DA)
- K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","")
- ;
- ; - Calling ECME for claims generation and transmission / REJECT handling
- N ACTION
- I $$SUBMIT^PSOBPSUT(PSONV) D I ACTION="Q"!(ACTION="^") Q
- . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF"))
- . I $$FIND^PSOREJUT(PSONV) D
- . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","Q")
- ;
- KILL S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2
- OUT K DIRUT,DTOUT,DUOUT,UPFLAGX D CLEAN Q
- DELETE K UPFLAGX D DELETE^PSOVER2 G:$G(UPFLAGX) OUT K PSOSD("NON-VERIFIED",$G(DRG)) Q
- QUIT S PSOQUIT="" D CLEAN Q
- UPSUS S $P(PSOSD("NON-VERIFIED",DRG),"^",2)=5,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","")
- Q
- CLEAN ;cleans up tmp("psorxdc") global
- I $O(^TMP("PSORXDC",$J,0)) F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD D
- .D PSOUL^PSSLOCK(RORD_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"S",1:""))
- .W !,$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:"Prescription",1:"Pending Order")_" #"_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:$P(^PSRX(RORD,0),"^"),1:RORD)_" NOT Discontinued."
- K ^TMP("PSORXDC",$J),RORD
- Q
- KV1 ;
- K PSOANSQD,DRET,LST,PSOQUIT,PSODRUG,PSONEW,SIG,PSODIR,PHI,PRC,ORCHK,ORDRG,PSOSIGFL,PSORX("ISSUE DATE"),PSORX("FILL DATE"),CLOZPAT
- KV K DIR,DIRUT,DTOUT,DUOUT
- Q
- NVA ;
- I $P(PSOSD(STA,DNM),"^",11) D NVA^PSODRDU1 Q
- N PSOOI,CLASS,FLG,X,Y,RXREC,IFN
- S (Y,FLG)=""
- S RXREC=$P(PSOSD(STA,DNM),"^",10),PSOOI=+$G(^PS(55,DFN,"NVA",RXREC,0)),IFN=RXREC N DNM
- F S Y=$O(^PSDRUG("ASP",PSOOI,Y)) Q:Y=""!(FLG) S DNM=$P(^PSDRUG(Y,0),"^"),CLASS=$P(^PSDRUG(Y,0),"^",2) I PSODRUG("NAME")=DNM!(CLASS=PSODRUG("VA CLASS")) D DSP^PSODRDU1 S FLG=1 Q
- Q
- REMOTE ;
- K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) D
- .I $T(HAVEHDR^ORRDI1)']"" Q
- .I '$$HAVEHDR^ORRDI1 Q
- .I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D Q
- ..I $T(REMOTE^PSORX1)]"" Q
- ..W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2
- .W !,"Now doing remote order checks. Please wait..."
- .D REMOTE^PSOORRDI(PSODFN,+$P($G(^PSRX(PSONV,0)),"^",6))
- .I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q
- .I $D(^TMP($J,"DD")) D DUP^PSOORRD2
- .I $D(^TMP($J,"DC")) D CLS^PSOORRD2
- .I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2
- K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN)
- Q
- NOALRGY ;
- W $C(7),!,"There is no allergy assessment on file for this patient."
- W !,"You will be prompted to intervene if you continue with this prescription"
- K DIR
- S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
- I 'Y S PSZZQUIT=1 Q
- S PSORX("INTERVENE")=0
- D EN1^PSORXI(PSONV)
- Q
- ; Ensure that the prescription has a provider
- CHKPRV(RXIEN) ; EP
- N DIR,RET,Y
- S RET=$P(^PSRX(RXIEN,0),U,4)
- I 'RET D
- .S DIR("A")="Select Ordering Provider",DIR("B")=""
- .W !!,"This prescription is missing an Ordering Provider."
- .W !,"Enter ^ to bypass, ^^ to exit loop.",!
- .S DIR(0)="52,4" D ^DIR
- .S RET=+Y
- .I $D(DIROUT) S PSOQUIT=1 Q
- .I RET>0 D
- ..S $P(^PSRX(RXIEN,0),U,4)=RET
- ..D ^PSORXPR
- Q RET
- PSOVER1 ;BHAM ISC/SAB - verify one rx ;29-May-2012 15:17;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,1002,1004,1007,1011,202,207,148,243,268,281,1015**;DEC 1997;Build 62
- +2 ;External reference ^PSDRUG( supported by DBIA 221
- +3 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- +4 ;External reference ^PS(55 supported by DBIA 2228
- +5 ;External reference to PSSORPH is supported by DBIA 3234
- +6 ;External references to ^ORRDI1 supported by DBIA 4659
- +7 ;External reference ^XTMP("ORRDI" supported by DBIA 4660
- +8 ; Modified - IHS/CIA/PLS - 01/29/04 - Line CHANGE+3
- +9 ; IHS/CIA/PLS - 12/16/04 - Lines REDO+1, EDIT+1, new EP (CHKPRV)
- +10 ; IHS/MSC/PLS - 07/10/08 - Changed references to PSOVER array to PSOVERA
- +11 ; IHS/MSC/PLS - 06/30/11 - Lines REDO+5 and new NVA EP to match patch 202
- REDO ;
- +1 SET (DRG,PSODRUG("NAME"))=$PIECE(^PSDRUG(+$PIECE(^PSRX(PSONV,0),"^",6),0),"^")
- SET PSODRUG("VA CLASS")=$PIECE(^(0),"^",2)
- +2 IF '$DATA(PSODFN)
- SET PSODFN=$PIECE(^PSRX(PSONV,0),"^",2)
- +3 ; IHS/CIA/PLS - 12/16/04 - Added check and message.
- +4 IF '$$CHKPRV(PSONV)
- Begin DoDot:1
- +5 WRITE !,"This prescription lacks an ordering provider and can't",!,"be processed until one is selected!"
- End DoDot:1
- QUIT
- +6 SET (STA,DNM)=""
- SET PSDPSTOP=0
- SET $PIECE(PSONULN,"-",79)="-"
- FOR
- SET STA=$ORDER(PSOSD(STA))
- IF STA=""
- QUIT
- FOR
- SET DNM=$ORDER(PSOSD(STA,DNM))
- IF DNM=""
- QUIT
- KILL PSZZZDUP
- IF $PIECE(PSOSD(STA,DNM),"^",2)<10
- Begin DoDot:1
- +7 ;IHS/MSC/PLS - 06/30/2011
- +8 IF STA="ZNONVA"
- DO NVA
- QUIT
- +9 ;I PSODRUG("NAME")=$P(DNM,"^")&(PSONV'=$P(PSOSD(STA,DNM),"^")) S PSZZZDUP=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR D DUP^PSODRDUP S PSDTSTOP=1
- +10 IF PSODRUG("NAME")=$PIECE(DNM,"^")&(PSONV'=$PIECE(PSOSD(STA,DNM),"^"))
- SET PSZZZDUP=1
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press RETURN to continue"
- WRITE !
- DO ^DIR
- KILL DIR
- SET PSDTSTOP=1
- +11 IF PSODRUG("VA CLASS")]""
- IF $EXTRACT(PSODRUG("VA CLASS"),1,4)=$EXTRACT($PIECE(PSOSD(STA,DNM),"^",5),1,4)
- IF PSODRUG("NAME")'=$PIECE(DNM,"^")
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press RETURN to continue"
- WRITE !
- DO ^DIR
- KILL DIR
- DO CLS^PSODRDUP
- SET PSDTSTOP=1
- +12 IF $GET(PSZZZDUP)
- IF $GET(PSVFLAG)
- IF $PIECE($GET(^PSRX($PIECE(PSOSD(STA,DNM),"^"),"STA")),"^")=12
- IF $DATA(^PS(52.4,$PIECE(PSOSD(STA,DNM),"^"),0))
- SET DA=$PIECE(PSOSD(STA,DNM),"^")
- SET DIK="^PS(52.4,"
- DO ^DIK
- KILL DIK
- +13 IF $GET(PSZZZDUP)
- IF $GET(PSVFLAG)
- IF $PIECE($GET(^PSRX($PIECE(PSOSD(STA,DNM),"^"),"STA")),"^")'=12
- SET PSZZQUIT=1
- End DoDot:1
- +14 KILL MSG
- IF $GET(PSZZQUIT)
- IF $GET(PSVFLAG)
- KILL PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP
- DO CLEAN
- QUIT
- +15 DO REMOTE
- +16 KILL PSODRUG,PSODFN,PSZZZDUP,DNM,PSZZQUIT
- ALLR ;Allergy check
- +1 SET PSONOAL=""
- DO ALLERGY^PSOORUT2
- IF PSONOAL'=""
- DO NOALRGY
- KILL PSONOAL
- IF $GET(PSZZQUIT)
- KILL MSG,PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP
- DO CLEAN
- QUIT
- +2 IF '$PIECE($GET(^PSRX(PSONV,3)),"^",6)
- GOTO EDIT
- +3 IF '$GET(PSDTSTOP)
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- KILL PSDTSTOP
- GOTO OUT
- +4 WRITE !!,"A Drug-Allergy Reaction exists for this medication!",!!,"***SIGNIFICANT*** Allergy Reaction"
- +5 WRITE !,"Drug: ",$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(PSONV,0)),"^",6),0)),"^")
- +6 IF $ORDER(^PSRX(PSONV,"DAI",0))
- WRITE !?6,"Ingredients: "
- Begin DoDot:1
- +7 FOR PSPPP=0:0
- SET PSPPP=$ORDER(^PSRX(PSONV,"DAI",PSPPP))
- IF 'PSPPP
- QUIT
- IF $GET(^(PSPPP,0))'=""
- IF $X+$LENGTH($GET(^PSRX(PSONV,"DAI",PSPPP,0)))+2>IOM
- WRITE !?19
- WRITE $GET(^PSRX(PSONV,"DAI",PSPPP,0))_", "
- End DoDot:1
- +8 WRITE !
- KILL DIR,PSPPP
- SET DIR(0)="Y"
- SET DIR("B")="Y"
- SET DIR("A")="Do you want to intervene?"
- DO ^DIR
- KILL DIR
- IF X["^"!($DATA(DTOUT))!($DATA(DUOUT))
- KILL PSDTSTOP
- GOTO OUT
- +9 IF Y
- SET PSORX("INTERVENE")=0
- DO EN1^PSORXI(PSONV)
- EDIT IF $GET(PKI1)=2
- DO DCV1^PSOPKIV1
- GOTO OUT
- +1 ; IHS/CIA/PLS - 12/16/04 - Corrected misspelling
- +2 ;K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to procede with verification"
- +3 KILL PSDTSTOP
- SET DIR("A")="EDIT"
- SET DIR("B")="N"
- SET DIR(0)="SB^Y:YES;N:NO;P:PROFILE"
- SET DIR("?")="Enter Y to change this RX, P to see a profile, or N to proceed with verification"
- +4 DO ^DIR
- KILL DIR
- IF Y="Y"
- IF $GET(PSOACT)]""
- SET VALMBCK="R"
- GOTO OUT
- +5 IF $DATA(DIRUT)
- IF $GET(PSOCLK)
- SET PSOCQ=1
- GOTO OUT
- +6 IF $DATA(DIRUT)
- IF $GET(PSOACT)]""
- SET VALMBCK="R"
- GOTO OUT
- +7 IF Y="N"
- GOTO VERIFY
- IF Y="P"
- GOTO PROF
- IF "YNP"'[$EXTRACT(Y)
- GOTO OUT
- CHANGE SET DA=PSONV
- SET (PSRX1,PSRX2)=$PIECE(^PSRX(PSONV,0),"^",6)
- +1 SET DEA1=1
- SET DEA2=0
- SET PSDOLD=+DA
- SET DIE="^PSRX("
- SET DR="3;7;8;9;4;5;12;1;22;11;"_$SELECT($PIECE(PSOPAR,"^",12):"35;",1:"")_$SELECT($PIECE(PSOPAR,"^",15):"10.6",1:"")_";@2"
- DO ^DIE
- +2 ;I PSRX1'=PSRX2,DEA1'=DEA2 S DR="6////"_PSRX1 D ^DIE
- +3 ;IHS/CIA/PLS - 01/29/04 - Prompt for IHS fields
- +4 SET DR="27;9999999.06;9999999.02;17;28;29;9999999.14"
- DO ^DIE
- +5 DO EXPIRE
- KILL DIE,DR,DEA1,DEA2,P(5),PSRX1,PSRX2
- +6 KILL PSD(PSDOLD)
- SET PSDNEW=$PIECE(^PSDRUG($PIECE(^PSRX(PSONV,0),"^",6),0),"^")_"^"_PSONV
- SET PSD(PSDNEW)=PSONV_"^*^1^"_$PIECE(^PSDRUG($PIECE(^PSRX(PSONV,0),"^",6),0),"^",2)
- +7 SET DA=PSONV
- DO ^PSORXPR
- +8 IF PSDNEW=PSDOLD
- GOTO EDIT
- GOTO REDO
- PROF IF '$DATA(PSOSD)
- WRITE !,$CHAR(7),"This patient has no other prescriptions on file",!!
- GOTO EDIT
- QUIT
- +1 DO ^PSODSPL
- GOTO EDIT
- QUIT
- +2 ;
- EXPIRE SET RX0=^PSRX(DA,0)
- SET X1=$PIECE($PIECE(RX0,"^",13),".")
- SET X2=$PIECE(RX0,"^",9)+1*$PIECE(RX0,"^",8)
- SET X2=$SELECT($PIECE(RX0,"^",8)=X2:X2,X2<181:184,X2=360:366,1:X2)
- SET X=X1
- IF X1&X2
- DO C^%DTC
- +1 KILL ^PS(55,PSDFN,"P","A",+$PIECE(^PSRX(DA,2),"^",6),DA)
- SET ^PS(55,PSDFN,"P","A",X,DA)=""
- SET $PIECE(^PSRX(DA,2),"^",6)=X
- SET $PIECE(^PS(52.4,DA,0),"^",7)=X
- QUIT
- VERIFY IF '$PIECE(PSOPAR,"^",2)
- GOTO VERY
- +1 SET DIR("A")="VERIFY FOR "_PSONAM_" ? (Y/N/Delete/Quit): "
- SET DIR("B")="Y"
- SET DIR(0)="SA^Y:YES;N:NO;D:DELETE;Q:QUIT"
- +2 SET DIR("?",1)="Enter Y (or return) to verify this prescription"
- SET DIR("?",2)="N to leave this prescription non-verified and to end this session of verification"
- SET DIR("?")="D to delete this prescription"
- +3 DO ^DIR
- KILL DIR
- IF Y="N"
- GOTO OUT
- IF "Q^"[$EXTRACT(Y)
- GOTO QUIT
- IF Y="D"
- GOTO DELETE
- VERY IF $GET(PKI1)=1
- DO REA^PSOPKIV1
- IF '$DATA(PKIR)
- GOTO VERIFY
- +1 KILL ^PSRX(PSONV,"DAI")
- SET $PIECE(^PSRX(PSONV,3),"^",6)=""
- +2 KILL ^PSRX(PSONV,"DRI"),SPFL
- +3 IF '$ORDER(^PSRX(PSONV,6,0))
- Begin DoDot:1
- +4 WRITE !!,"Dosing Instructions Missing. Please add!",!
- +5 IF $PIECE($GET(^PSRX(PSONV,"SIG")),"^")]""
- IF '$PIECE($GET(^("SIG")),"^",2)
- WRITE "SIG: "_$PIECE(^PSRX(PSONV,"SIG"),"^"),!
- +6 IF $PIECE($GET(^PSRX(PSONV,"SIG")),"^",2)
- IF $ORDER(^PSRX(PSONV,"SIG1",0))
- Begin DoDot:2
- +7 WRITE "SIG: "
- FOR I=0:0
- SET I=$ORDER(^PSRX(PSONV,"SIG1",I))
- IF 'I
- QUIT
- WRITE ^PSRX(PSONV,"SIG1",I,0),!
- End DoDot:2
- KILL I
- +8 SET DA=PSONV
- SET PSOVER=1
- KILL DIR,DIRUT,DUOUT,DTOUT
- +9 SET PSODRUG("IEN")=$PIECE(^PSRX(DA,0),"^",6)
- SET PSODFN=$PIECE(^(0),"^",2)
- SET PSORXED("IRXN")=DA
- SET PSODRUG("OI")=$PIECE(^PSRX(DA,"OR1"),"^")
- +10 DO DOSE^PSSORPH(.DOSE,PSODRUG("IEN"),"O",PSODFN)
- DO ^PSOORED3
- +11 KILL PSODFN,PSODRUG("IEN"),DOSE,PSOVER
- +12 IF '$GET(ENT)
- SET DUOUT=1
- +13 IF $DATA(DUOUT)!($DATA(DTOUT))
- QUIT
- +14 KILL DIR,DIRUT,DUOUT,DTOUT
- SET DIE=52
- SET DR=114
- DO ^DIE
- KILL DIE,DR,DTOUT
- +15 IF X'=""
- DO SIG^PSOHELP
- IF $GET(INS1)]""
- DO EN^DDIOL($EXTRACT(INS1,2,9999999))
- SET PSORXED("SIG",1)=$EXTRACT(INS1,2,9999999)
- +16 DO EN^PSOFSIG(.PSORXED,1)
- DO UDSIG^PSOORED3
- HANG 2
- End DoDot:1
- IF $DATA(DUOUT)!($DATA(DTOUT))
- WRITE !!,"Rx: "_$PIECE(^PSRX(DA,0),"^")_" not Verified!!",!
- HANG 2
- GOTO OUT
- +17 SET DA=PSONV
- SET $PIECE(^PSRX(DA,2),"^",10)=DUZ
- IF $PIECE(^PSRX(DA,2),"^",2)>DT
- IF $PIECE(PSOPAR,"^",6)
- SET (SPFL1,PSOVER)=""
- SET PSORX("FILL DATE")=$PIECE(^(2),"^",2)
- SET RXF=0
- DO UPSUS
- SET PSTRIVER=1
- DO SUS^PSORXL
- KILL PSORX("FILL DATE"),PSTRIVER
- GOTO KILL
- +18 ; IHS/MSC/PLS - 07/10/08
- +19 ;S PSOVER(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
- +20 SET PSOVERA(PSONV)=""
- SET $PIECE(^PSRX(PSONV,"STA"),"^")=0
- SET $PIECE(PSOSD("NON-VERIFIED",DRG),"^",2)=0
- SET PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
- +21 IF $GET(PKI1)=1
- IF $GET(PKIR)]""
- DO ACT^PSOPKIV1(DA)
- +22 KILL PSOSD("NON-VERIFIED",DRG)
- DO EN^PSOHLSN1(PSONV,"SC","CM","")
- +23 ;
- +24 ; - Calling ECME for claims generation and transmission / REJECT handling
- +25 NEW ACTION
- +26 IF $$SUBMIT^PSOBPSUT(PSONV)
- Begin DoDot:1
- +27 SET ACTION=""
- DO ECMESND^PSOBPSU1(PSONV,,,$SELECT($ORDER(^PSRX(PSONV,1,0)):"RF",1:"OF"))
- +28 IF $$FIND^PSOREJUT(PSONV)
- Begin DoDot:2
- +29 SET ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","Q")
- End DoDot:2
- End DoDot:1
- IF ACTION="Q"!(ACTION="^")
- QUIT
- +30 ;
- KILL SET DA=PSONV
- SET DIK="^PS(52.4,"
- DO ^DIK
- KILL DA,DIK
- DO DCORD^PSONEW2
- OUT KILL DIRUT,DTOUT,DUOUT,UPFLAGX
- DO CLEAN
- QUIT
- DELETE KILL UPFLAGX
- DO DELETE^PSOVER2
- IF $GET(UPFLAGX)
- GOTO OUT
- KILL PSOSD("NON-VERIFIED",$GET(DRG))
- QUIT
- QUIT SET PSOQUIT=""
- DO CLEAN
- QUIT
- UPSUS SET $PIECE(PSOSD("NON-VERIFIED",DRG),"^",2)=5
- SET PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
- KILL PSOSD("NON-VERIFIED",DRG)
- DO EN^PSOHLSN1(PSONV,"SC","CM","")
- +1 QUIT
- CLEAN ;cleans up tmp("psorxdc") global
- +1 IF $ORDER(^TMP("PSORXDC",$JOB,0))
- FOR RORD=0:0
- SET RORD=$ORDER(^TMP("PSORXDC",$JOB,RORD))
- IF 'RORD
- QUIT
- Begin DoDot:1
- +2 DO PSOUL^PSSLOCK(RORD_$SELECT($PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^")="P":"S",1:""))
- +3 WRITE !,$SELECT($PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^")=52:"Prescription",1:"Pending Order")_" #"_$SELECT($PIECE(^TMP("PSORXDC",$JOB,RORD,0),"^")=52:$PIECE(^PSRX(RORD,0),"^"),1:RORD)_" NOT Discontinued."
- End DoDot:1
- +4 KILL ^TMP("PSORXDC",$JOB),RORD
- +5 QUIT
- KV1 ;
- +1 KILL PSOANSQD,DRET,LST,PSOQUIT,PSODRUG,PSONEW,SIG,PSODIR,PHI,PRC,ORCHK,ORDRG,PSOSIGFL,PSORX("ISSUE DATE"),PSORX("FILL DATE"),CLOZPAT
- KV KILL DIR,DIRUT,DTOUT,DUOUT
- +1 QUIT
- NVA ;
- +1 IF $PIECE(PSOSD(STA,DNM),"^",11)
- DO NVA^PSODRDU1
- QUIT
- +2 NEW PSOOI,CLASS,FLG,X,Y,RXREC,IFN
- +3 SET (Y,FLG)=""
- +4 SET RXREC=$PIECE(PSOSD(STA,DNM),"^",10)
- SET PSOOI=+$GET(^PS(55,DFN,"NVA",RXREC,0))
- SET IFN=RXREC
- NEW DNM
- +5 FOR
- SET Y=$ORDER(^PSDRUG("ASP",PSOOI,Y))
- IF Y=""!(FLG)
- QUIT
- SET DNM=$PIECE(^PSDRUG(Y,0),"^")
- SET CLASS=$PIECE(^PSDRUG(Y,0),"^",2)
- IF PSODRUG("NAME")=DNM!(CLASS=PSODRUG("VA CLASS"))
- DO DSP^PSODRDU1
- SET FLG=1
- QUIT
- +6 QUIT
- REMOTE ;
- +1 KILL ^TMP($JOB,"DD"),^TMP($JOB,"DC"),^TMP($JOB,"DI"),^TMP($JOB,"DI"_PSODFN)
- Begin DoDot:1
- +2 IF $TEXT(HAVEHDR^ORRDI1)']""
- QUIT
- +3 IF '$$HAVEHDR^ORRDI1
- QUIT
- +4 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
- Begin DoDot:2
- +5 IF $TEXT(REMOTE^PSORX1)]""
- QUIT
- +6 WRITE !,"Remote data not available - Only local order checks processed."
- DO PAUSE^PSOORRD2
- End DoDot:2
- QUIT
- +7 WRITE !,"Now doing remote order checks. Please wait..."
- +8 DO REMOTE^PSOORRDI(PSODFN,+$PIECE($GET(^PSRX(PSONV,0)),"^",6))
- +9 IF $PIECE($GET(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0
- WRITE !,"Remote data not available - Only local order checks processed."
- DO PAUSE^PSOORRD2
- QUIT
- +10 IF $DATA(^TMP($JOB,"DD"))
- DO DUP^PSOORRD2
- +11 IF $DATA(^TMP($JOB,"DC"))
- DO CLS^PSOORRD2
- +12 IF $DATA(^TMP($JOB,"DI"_PSODFN))
- KILL ^TMP($JOB,"DI")
- MERGE ^TMP($JOB,"DI")=^TMP($JOB,"DI"_PSODFN)
- DO DRGINT^PSOORRD2
- End DoDot:1
- +13 KILL ^TMP($JOB,"DD"),^TMP($JOB,"DC"),^TMP($JOB,"DI"),^TMP($JOB,"DI"_PSODFN)
- +14 QUIT
- NOALRGY ;
- +1 WRITE $CHAR(7),!,"There is no allergy assessment on file for this patient."
- +2 WRITE !,"You will be prompted to intervene if you continue with this prescription"
- +3 KILL DIR
- +4 SET DIR(0)="SA^1:YES;0:NO"
- SET DIR("A")="Do you want to Continue?: "
- SET DIR("B")="N"
- DO ^DIR
- +5 IF 'Y
- SET PSZZQUIT=1
- QUIT
- +6 SET PSORX("INTERVENE")=0
- +7 DO EN1^PSORXI(PSONV)
- +8 QUIT
- +9 ; Ensure that the prescription has a provider
- CHKPRV(RXIEN) ; EP
- +1 NEW DIR,RET,Y
- +2 SET RET=$PIECE(^PSRX(RXIEN,0),U,4)
- +3 IF 'RET
- Begin DoDot:1
- +4 SET DIR("A")="Select Ordering Provider"
- SET DIR("B")=""
- +5 WRITE !!,"This prescription is missing an Ordering Provider."
- +6 WRITE !,"Enter ^ to bypass, ^^ to exit loop.",!
- +7 SET DIR(0)="52,4"
- DO ^DIR
- +8 SET RET=+Y
- +9 IF $DATA(DIROUT)
- SET PSOQUIT=1
- QUIT
- +10 IF RET>0
- Begin DoDot:2
- +11 SET $PIECE(^PSRX(RXIEN,0),U,4)=RET
- +12 DO ^PSORXPR
- End DoDot:2
- End DoDot:1
- +13 QUIT RET