- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m
r613 r623 1 PSOCAN2 2 ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281**;DEC 1997;Build 41 3 4 REINS 5 6 7 8 9 10 11 12 ACT 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","Q")33 34 35 36 37 38 39 40 41 42 43 44 45 SUS 46 47 48 49 50 51 52 DRGDRG 53 54 55 56 57 58 59 60 61 62 63 VERIFY 64 65 66 67 68 69 HLD 70 71 72 73 74 75 76 77 78 REF 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 KILL 94 95 96 DELREF 97 98 99 100 101 102 103 AUTOD 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 LOG 129 130 131 132 133 134 135 136 NVER 137 138 139 140 RMB(IDX) 141 142 143 144 145 146 147 148 1 PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am 2 ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259**;DEC 1997;Build 5 3 ;External reference to ^PSDRUG supported by dbia 221 4 REINS N DODR 5 I $P(^PSRX(DA,2),"^",6)<DT D Q 6 .S Y=$P(^PSRX(DA,2),"^",6) X ^DD("DD") 7 .W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" Drug: "_$S($D(^PSDRUG($P(^PSRX(DA,0),"^",6),0)):$P(^(0),"^"),1:""),!,"Expired "_Y_" and cannot be Reinstated!",! 8 .D PAUSE^VALM1 9 I $D(^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA)) S PSCAN($P(^PSRX(DA,0),"^"))=DA_"^R",DODR=1 D AUTOD G ACT 10 I $P(PSOPAR,"^",2),'$D(^XUSEC("PSORPH",DUZ)) D VERIFY D D AREC^PSOCAN1 Q 11 .S RX1=$P(^PSRX(DA,0),"^") S:'$D(PSCAN(RX1)) PSCAN(RX1)=DA_"^R" K RX1 12 ACT W ! F I=1:1:80 W "=" 13 D ^PSOBUILD S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:""),HOLDRX=RX 14 W !!,RX_" "_DRG D DRGDRG S RX=HOLDRX K HOLDRX Q:$P(^PSRX(+PSCAN(RX),"STA"),"^")'=12!($G(PSORX("DFLG"))) S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2) D CAN^PSOCAN W ! 15 N RXIEN S RXIEN=DA 16 ;Takes action on reinstated Rx's 17 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF 18 S (LPRT,LREF)="" F LL=0:0 S LL=$O(^PSRX(DA,"L",LL)) Q:'LL S LPRT=$P($G(^PSRX(DA,"L",LL,0)),"."),LREF=$P($G(^(0)),"^",2) 19 I 'RFCNT S FDT=$S($P($G(^PSRX(DA,2)),"^",2)'="":$P($G(^PSRX(DA,2)),"^",2),1:$P($G(^PSRX(DA,2)),"^")) S RELDT=$P(^(2),"^",13),RELDT=$P(RELDT,".") 20 I RFCNT S FDT=$P($G(^PSRX(DA,1,RFCNT,0)),"^"),RELDT=$P(^(0),"^",18),RELDT=$P(RELDT,".") 21 S Y=FDT D DD^%DT S XFDT=Y I RELDT'="" S Y=RELDT D DD^%DT S XRELDT=Y 22 I LPRT'="" S Y=LPRT D DD^%DT S XLPDT=Y 23 ;If Rx was released, do nothing 24 I RELDT'="" W !,RX_" Reinstated -- ",!?3,$S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released: "_$G(XRELDT) H 3 Q 25 ;If Rx not released, check fill/refill date for action 26 I $G(PSXSYS) D REINS^PSOCMOPA I $G(XFLAG) K XFLAG Q 27 W !,"Prescription #"_RX_" REINSTATED!" 28 ; 29 I $$SUBMIT^PSOBPSUT(RXIEN) D 30 . N ACTION 31 . D ECMESND^PSOBPSU1(RXIEN,,,$S($O(^PSRX(RXIEN,1,0)):"RF",1:"OF")) 32 . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","I") 33 ; 34 W !?3,"Prescription #",RX," " 35 I FDT<DT D 36 .W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released:" 37 .S DIR("A")=" ** Do you want to print the label now",DIR("B")="N",DIR(0)="Y",DIR("?")="Enter 'Y' to print the label now. If 'N' is entered, the label may be reprinted through reprint at a later date." 38 .D ^DIR K DIR Q:$G(DIRUT)!('Y) S PPL=DA D Q^PSORXL Q 39 I FDT=DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"") 40 I W ?56,"Released:",!?5,"Either print the label using the reprint option ",!?7,"or check later to see if the label has been printed." Q 41 I FDT>DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"") 42 I W ?56,"Released:" I '$G(DODR) W !?5,"Placing Rx on suspense. Please wait..." D SUS 43 K DODR 44 Q 45 SUS ;Adds rec to suspense 46 S ACT=1,RXN=DA,RX0=^PSRX(DA,0),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN 47 S RXP=$S($D(RXP):RXP,1:0),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_FDT_";.03///"_$P(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$G(PSOSITE)_";2///0" K DD,DO D FILE^DICN 48 I +$G(Y),$G(RFCNT)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFCNT) 49 S DA=RXN,$P(^PSRX(DA,"STA"),"^")=5,LFD=$E($P(^PSRX(DA,3),"^"),4,5)_"-"_$E($P(^(3),"^"),6,7)_"-"_$E($P(^(3),"^"),2,3) 50 S ACOM="RX Placed on Suspense until "_LFD D AREC^PSOCAN1 S ST="SC",PHST="ZS" D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST 51 Q 52 DRGDRG ;Checks for drug/drug interaction, duplicate drug and class 53 Q:$P(^PSRX(DA,2),"^",6)<DT 54 S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD" 55 S STAT=$P(STA,"^",$P(^PSRX(DA,"STA"),"^")+1) 56 S X=$P(^PSRX(DA,0),"^",6),DIC="^PSDRUG(",DIC(0)="MZO" D ^DIC K DIC Q:$D(DTOUT)!(Y<0) 57 K HOLD S NAME=$P(Y(0),"^") I +$G(PSOSD(STAT,NAME))=+PSCAN(RX) S HOLD(STAT,NAME)=$G(PSOSD(STAT,NAME)) K PSOSD(STAT,NAME) 58 S:$G(PSONEW("OLD VAL"))=+Y PSODRG("QFLG")=1 59 K PSOY S PSOY=Y,PSOY(0)=Y(0) 60 S PSORENW("OIRXN")=DA D SET^PSODRG,POST^PSODRG S REA=$P(PSCAN($P(^PSRX(PSORENW("OIRXN"),0),"^")),"^",2) 61 W ! S:$G(HOLD(STAT,NAME))]"" PSOSD(STAT,NAME)=$G(HOLD(STAT,NAME)) K HOLD,STA,STAT,PSORENW("OIRXN") 62 Q 63 VERIFY ;Put in non-verify file 64 S PSRXDA=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXDA,DIC(0)="ML",DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4////"_DT 65 K DD,DO D FILE^DICN K DIC,DLAYGO,DINUM 66 S DA=PSRXDA S $P(^PSRX(DA,"STA"),"^")=1 67 S ST="SC",PHST="IP",VCOM="Put in non-verified status" D EN^PSOHLSN1(DA,ST,PHST,VCOM) K ST,PHST,VCOM 68 Q 69 HLD N PSDTEST,PDA,CMOP,SUSD I $P(^PSRX(DA,"STA"),"^")=3 D 70 .S ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while on hold during Rx cancel. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" 71 .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q 72 .S (IFN,SUSD)=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^") 73 .Q:'$G(SUSD) I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT 74 ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1 75 ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q 76 ..S PSDTEST=1 77 Q 78 REF S IFN=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN I $P($G(^PSRX(DA,1,IFN,0)),"^")=SUSD,'$P(^(0),"^",18) D 79 .D DELREF I $G(PSORFDEL) K PSORFDEL Q 80 .;PSO*7*259;CHECK IF REFILL RELEASED OR LABEL PRINTED 81 .I $P($G(^PSRX(DA,1,IFN,0)),"^",18)]"" Q ;REFILL RELEASED 82 .N PSONODEL,PSOLBL S PSONODEL=0 83 .I $P(^PSRX(DA,"STA"),"^")=5 D REF^PSOCAN4 Q:PSONODEL 84 .S PSOLBL="" F S PSOLBL=$O(^PSRX(DA,"L",PSOLBL),-1) Q:'PSOLBL Q:PSONODEL Q:$P(^PSRX(DA,"L",PSOLBL,0),"^",2)<IFN I $P(^PSRX(DA,"L",PSOLBL,0),"^",2)=IFN S PSONODEL=1 85 .Q:PSONODEL 86 .K PSORFDEL K ^PSRX(DA,1,IFN),^PSRX("AD",SUSD,DA,IFN),^PSRX(DA,1,"B",SUSD,IFN) 87 .S $P(^PSRX(DA,1,0),"^",4)=$P(^PSRX(DA,1,0),"^",4)-1,DA(1)=DA 88 .S NODE=0 D SPR^PSOUTL K DA(1),RF,NODE 89 S IFN=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN I '$O(^PSRX(DA,1,IFN)) S $P(^PSRX(DA,3),"^")=+$P(^PSRX(DA,1,IFN,0),"^"),$P(^(3),"^",2)=SUSD 90 I '$O(^PSRX(DA,1,0)) S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,2),"^",2),$P(^PSRX(DA,3),"^",2)=SUSD 91 K IFN,SUSD 92 Q 93 KILL K %,ACNT,ACOM,ACT,ALL,BCNUM,CMOP,CNT,DA,DAYS360,DEAD,DRG,DIRUT,DR,DRUG,DTOUT,DUOUT,FDT,HOLD,I,II,IN,IT,JJ,LC,LFD,LINE,LL,LPRT,LREF,LSI,NAME,NDF,NOEXP,NSF,OUT,RXSP,EN,WARN K:'$G(POERR) INCOM 94 K PSODRUG,PCNT,POP,PPL,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSOCMOP,PSODFN,PSODRG,PSOOPT,PSOSD,PSPOP,PSRXDA,PSS,PSVC,PSONOOR 95 K REA,RELDT,RF,RFDATE,RFCNT,RFL,RFL1,RFLL,RP,RX,RX0,RXCNT,RXDA,RXN,RXNUM,RXP,RXREC,RXREF,RXS,SDATE,SPCANC,SS,STAT,SUB,X,XFDT,XLPDT,XRELDT,Y D KVA^VADPT Q 96 DELREF ; 97 N RDL,PSCNODE 98 S PSORFDEL=0 99 F RDL=0:0 S RDL=$O(^PSRX(DA,4,RDL)) Q:'RDL I $G(IFN)=$P($G(^PSRX(DA,4,RDL,0)),"^",3) S PSCNODE=$G(^(0)) 100 I $G(PSCNODE)="" Q 101 I +$P(PSCNODE,"^",4)<3 S PSORFDEL=1 102 Q 103 AUTOD ;reinstates Rxs dc'd by date of death 104 I $G(^PSRX(DA,"DDSTA"))']"" K ^PSRX("APSOD",+$P(^PSRX(DA,0),"^",2),DA),DODR Q 105 S DODS=$P(^PSRX(DA,"DDSTA"),"^"),DODD=$P(^("DDSTA"),"^",2,245) 106 S FILE=$P(DODS,";"),STA=$P(DODS,";",2) 107 I FILE=52.4 D Q 108 .S RXN=DA,^PS(52.4,DA,0)=DODD,DIK="^PS(52.4," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA 109 .S ST="SC",PHST="IP",ACOM="Date of Death Deleted. Returned to Non-Verified status." 110 .K ^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA),^PSRX(DA,"DDSTA") 111 .S DA=RXN D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,RXN 112 I FILE=52.5 D Q 113 .;Adds rec to suspense 114 .S RXN=DA,RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK 115 .S DIC="^PS(52.5,",DIC(0)="L",X=RXN K DD,DO D FILE^DICN S DA=+Y 116 .S ^PS(52.5,DA,0)=DODD,^PS(52.5,DA,"P")=0,LFD=$E($P(^PS(52.5,DA,0),"^",2),4,5)_"-"_$E($P(^(0),"^",2),6,7)_"-"_$E($P(^(0),"^",2),2,3) 117 .S DIK="^PS(52.5," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA 118 .S ACOM="Date of Death Deleted. RX Placed on Suspense until "_LFD 119 .K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA") 120 .I STA=5 S ST="SC",PHST="ZS" D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,LFD 121 I FILE=52 S ^PSRX(DA,"STA")=STA I STA=3!(STA=16) D Q 122 .S ^PSRX(DA,"H")=DODD,^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)="" 123 .S ACOM="Date of Death Deleted. Medication Returned to"_$S(STA=16:" Provider",1:"")_" Hold Status "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_"." 124 .D LOG,EN^PSOHLSN1(DA,"OH","",ACOM) K ACOM 125 .K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA") 126 S ACOM="Date of Death Deleted. Prescription Reinstated." D EN^PSOHLSN1(DA,"SC","CM",ACOM),LOG K ACOM 127 Q 128 LOG K ACNT F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=$G(ACNT)+1 129 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=$G(RFCNT)+1 S:RF>5 RFCNT=$G(RFCNT)+1 130 S ACNT=$G(ACNT)+1 131 D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM 132 K ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,% 133 S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",5),$P(^(3),"^",2)=$P(^(3),"^",8) 134 S $P(^PSRX(DA,3),"^",5)="",$P(^(3),"^",8)="" 135 Q 136 NVER ;Called from PSOCAN3, needs DA defined 137 N PSONVC,PSONVCP,PSONVCC 138 S PSONVC="SC",PSONVCP="IP",PSONVCC="Put in non-verified status" D EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC) 139 Q 140 RMB(IDX) ;remove Rx if found in array BBRX() (Bingo Board) 141 N ST4,ST5,ST6,K 142 S ST4=BBRX(IDX) Q:ST4'[(DA_",") 143 S ST6="" 144 F K=1:1 S ST5=$P(ST4,",",K) Q:'ST5 D 145 . S:ST5'=DA ST6=ST6_$S('ST6:"",1:",")_ST5 146 . S:ST6]"" BBRX(IDX)=ST6_"," K:ST6="" BBRX(IDX) 147 I '$D(BBRX) K BINGCRT 148 Q
Note:
See TracChangeset
for help on using the changeset viewer.
