APSPFNC6 ;IHS/MSC/PLS - Prescription Creation Support ;28-Mar-2016 11:53;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1011,1012,1016,1017,1018,1021**;Sep 23, 2004;Build 14
;=================================================================
;Returns string containing the possible pickup locations
GPKUP(DATA,USR,OI,ORDER) ; EP -
N AUTORX,RET,C,CRX,RSCH,OKERX,AUTOOR
S ORDER=$G(ORDER),AUTOOR=-1
;IHS/MSC/MGH 1016 If the order number is sent in and the order is e-prescribed, then renewals must be electronic.
S:ORDER'="" AUTOOR=$$CHKERX(ORDER)
S C=$$GET^XPAR("ALL","APSP AUTO RX CII PRESCRIBING")
S CRX=$$GET^XPAR("ALL","APSP AUTO RX ERX OF CS II")
S AUTORX=+$$GET^XPAR("ALL","APSP AUTO RX")
S RSCH=$$GET^XPAR("ALL","APSP AUTO RX SCHEDULE RESTRICT")
I AUTORX=0 D ;Internal Pharmacy
.S RET="CMW"
E I AUTORX=1 D ;Internal and External Pharmacy
.S OKERX=$$OKTOUSE(OI,RSCH)
.I '$$ERXUSER(USR) D ;User not able to select E
..S RET=$S(OKERX=2:"P",AUTOOR>0:"CP",1:"CMWP")
.E D
..;IHS/MSC/MGH Patch 1016 Changes to incorporate ERX field
..I '+OKERX D
...S RET=$S(AUTOOR>0:"CP",'AUTOOR:"CMW",1:"CMWP")
..E D
...S RET=$S(OKERX=2:"P",AUTOOR>0:"CP",'AUTOOR:"CMW",1:"CMWP")
...I AUTOOR'=0 S RET=RET_$S(OKERX>0:"E",$L(RSCH)&($$ERXOI(OI,RSCH)):"",$$ERXOI(OI,"2"):$S(CRX:"E",1:""),1:"E")
E I AUTORX=2 D ;External Pharmacy
.S OKERX=$$OKTOUSE(OI,RSCH)
.I '$$ERXUSER(USR) D ;User not able to select E
..S RET=$S(OKERX=2:"P",1:"CP")
.E D
..;IHS/MSC/MGH Patch 1016 Changes to incorporate ERX field
..I '+OKERX D
...S RET=$S(OKERX=2:"P",1:"CP")
..E D
...S RET=$S(OKERX=2:"P",1:"CP")
...S RET=RET_$S(OKERX>0:"E",$L(RSCH)&($$ERXOI(OI,RSCH)):"",$$ERXOI(OI,"2"):$S(CRX:"E",1:""),1:"E")
S DATA=RET
Q
; Returns ability of user to e-prescribe
; Input: USR - IEN to New Person File
; Output: 0 = e-Prescribing is not available to user
; 1 = e-Prescribing is available to user
ERXUSER(USR) ; EP
N RET
D ERXUSER^APSPFNC2(.RET,USR)
Q RET
; Returns match of orderable item to drug schedule
; Input: OIIEN - Orderable Item IEN
; SCH - SCHEDULE
; TPL - Invert return value
ERXOI(OIIEN,SCH,TPL) ; EP
N RET
S TPL=+$G(TPL,0)
D ERXOI^APSPFNC2(.RET,OIIEN,SCH)
Q $S(TPL:RET,1:'RET)
; Retransmit eRX order
; Input: ORD - IEN to Order File (100)
; Output: 1 = resent
RESEND(DATA,ORD,RXNUM) ;EP -
N PHARM,RX
S PHARM=+$$VALUE^ORCSAVE2(+ORD,"PHARMACY")
S RX=+$G(^OR(100,ORD,4))
I $P($G(^PSRX(RX,0)),U)=RXNUM D
.D EN^APSPELRX(RX,PHARM)
S DATA=1
Q
; Returns boolean value representing presence of reason and type in activity log.
CKRXACT(RX,REASON,TYPE) ;EP-
N RES,LP,PR,PT
S (LP,RES)=0
Q:'$G(RX) RES
Q:'$L($G(REASON)) RES
S TYPE=$G(TYPE)
F S LP=$O(^PSRX(RX,"A",LP)) Q:'LP D Q:RES
.S PR=$P(^PSRX(RX,"A",LP,0),U,2)
.Q:PR'=REASON
.S PT=$P($G(^PSRX(RX,"A",LP,9999999)),U,2)
.Q:PT=""
.S:TYPE[PT RES=1
Q RES
;Returns if this drug is OK to send as a eRX
OKTOUSE(OI,RSCH) ;function call
N RES,IEN,STOP,POI,NODE
S RES=1
I $L(RSCH)&($$ERXOI(OI,RSCH)) Q 0
S POI=$P($P($G(^ORD(101.43,OI,0)),U,2),";",1)
I POI="" Q RES
S IEN="" F S IEN=$O(^PSDRUG("ASP",POI,IEN)) Q:IEN=""!(RES=0) D
.S NODE=$G(^PSDRUG(IEN,0))
.Q:NODE=""
.I $P($G(^PSDRUG(IEN,999999935)),U,3)=1 S RES=0
.I $$ERXONLY(IEN) S RES=2
Q RES
CHKERX(ORDER) ;Find out if ORDER was an eRX one
N VALUE,RX
S VALUE=0,ORDER=$P(ORDER,";")
S RX="" S RX=$O(^PSRX("APL",ORDER,RX))
Q:RX="" VALUE
S VALUE=+$$GET1^DIQ(52,RX,9999999.23,"I")
Q VALUE
; Return ERX only of drug
; Input: Order File IEN
; Output: Boolean
ERXONLY(DRUG) ;EP- Patch 1021
N VAL
S VAL=$P($G(^PSDRUG(DRUG,999999935)),U,3)
Q VAL=2
; Return long name of drug
; Input: Order File IEN
GETLONG(RET,ORDER) ;EP-
N DRUG
S RET=""
S DRUG=$$VALUE^ORCSAVE2(ORDER,"DRUG")
Q:'+DRUG
S RET=$$GETLNGDG(DRUG)
Q
; Return long name of drug
; Input: Drug File IEN
GETLNGDG(DRUG) ;EP-
Q $$GET1^DIQ(50,DRUG,9999999.352)
;
; Find a site
LOC(ORIEN) ;
N PSOLOC,PSOINS,PSOSITE
S PSOLOC=$P($G(^OR(100,ORIEN,0)),U,10)
S PSOSITE=$$GET^XPAR("LOC.`"_PSOLOC_U_"DIV.`"_DUZ(2)_"^SYS","APSP AUTO RX DIV")
I 'PSOSITE D
.S PSOSITE=0
.I PSOLOC["SC" D
..S PSOLOC=+PSOLOC
..S PSOINS=$P($G(^SC(PSOLOC,0)),U,4)
..Q:'PSOINS
..S PSOSITE=$$DIV(PSOINS)
.S:'PSOSITE PSOSITE=$$DIV(DUZ(2))
.S:'PSOSITE PSOSITE=$$DIV(+$$SITE^VASITE)
Q $S($G(PSOSITE):PSOSITE,1:0)
; This screen is used by the APSP AUTO RX DIV parameter.
; Input: DIV - Pointer to Institution (4) file
DIVSCN(ENT) ;
I $G(ENT)["DIC(4," Q ''$$DIV(+ENT)
I $G(ENT)["DIC(4.2," Q 1
I $G(ENT)["SC(" Q 1
Q 0
; Return Pharmacy Division
DIV(INS) Q $O(^PS(59,"D",+INS,0))
;
; Returns the last activity type for requested reason
LASTACT(RX,REASON) ;EP-
N RES,LP,PR,PT,FLG
S FLG=0,RES=""
S LP=$C(1)
Q:'$G(RX) RES
Q:'$L($G(REASON)) RES
F S LP=$O(^PSRX(RX,"A",LP),-1) Q:'LP D Q:FLG
.S PR=$P(^PSRX(RX,"A",LP,0),U,2)
.Q:PR'=REASON
.S FLG=1
.S RES=$P($G(^PSRX(RX,"A",LP,9999999)),U,2)
Q RES
APSPFNC6 ;IHS/MSC/PLS - Prescription Creation Support ;28-Mar-2016 11:53;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1011,1012,1016,1017,1018,1021**;Sep 23, 2004;Build 14
+2 ;=================================================================
+3 ;Returns string containing the possible pickup locations
GPKUP(DATA,USR,OI,ORDER) ; EP -
+1 NEW AUTORX,RET,C,CRX,RSCH,OKERX,AUTOOR
+2 SET ORDER=$GET(ORDER)
SET AUTOOR=-1
+3 ;IHS/MSC/MGH 1016 If the order number is sent in and the order is e-prescribed, then renewals must be electronic.
+4 IF ORDER'=""
SET AUTOOR=$$CHKERX(ORDER)
+5 SET C=$$GET^XPAR("ALL","APSP AUTO RX CII PRESCRIBING")
+6 SET CRX=$$GET^XPAR("ALL","APSP AUTO RX ERX OF CS II")
+7 SET AUTORX=+$$GET^XPAR("ALL","APSP AUTO RX")
+8 SET RSCH=$$GET^XPAR("ALL","APSP AUTO RX SCHEDULE RESTRICT")
+9 ;Internal Pharmacy
IF AUTORX=0
Begin DoDot:1
+10 SET RET="CMW"
End DoDot:1
+11 ;Internal and External Pharmacy
IF '$TEST
IF AUTORX=1
Begin DoDot:1
+12 SET OKERX=$$OKTOUSE(OI,RSCH)
+13 ;User not able to select E
IF '$$ERXUSER(USR)
Begin DoDot:2
+14 SET RET=$SELECT(OKERX=2:"P",AUTOOR>0:"CP",1:"CMWP")
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 ;IHS/MSC/MGH Patch 1016 Changes to incorporate ERX field
+17 IF '+OKERX
Begin DoDot:3
+18 SET RET=$SELECT(AUTOOR>0:"CP",'AUTOOR:"CMW",1:"CMWP")
End DoDot:3
+19 IF '$TEST
Begin DoDot:3
+20 SET RET=$SELECT(OKERX=2:"P",AUTOOR>0:"CP",'AUTOOR:"CMW",1:"CMWP")
+21 IF AUTOOR'=0
SET RET=RET_$SELECT(OKERX>0:"E",$LENGTH(RSCH)&($$ERXOI(OI,RSCH)):"",$$ERXOI(OI,"2"):$SELECT(CRX:"E",1:""),1:"E")
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;External Pharmacy
IF '$TEST
IF AUTORX=2
Begin DoDot:1
+23 SET OKERX=$$OKTOUSE(OI,RSCH)
+24 ;User not able to select E
IF '$$ERXUSER(USR)
Begin DoDot:2
+25 SET RET=$SELECT(OKERX=2:"P",1:"CP")
End DoDot:2
+26 IF '$TEST
Begin DoDot:2
+27 ;IHS/MSC/MGH Patch 1016 Changes to incorporate ERX field
+28 IF '+OKERX
Begin DoDot:3
+29 SET RET=$SELECT(OKERX=2:"P",1:"CP")
End DoDot:3
+30 IF '$TEST
Begin DoDot:3
+31 SET RET=$SELECT(OKERX=2:"P",1:"CP")
+32 SET RET=RET_$SELECT(OKERX>0:"E",$LENGTH(RSCH)&($$ERXOI(OI,RSCH)):"",$$ERXOI(OI,"2"):$SELECT(CRX:"E",1:""),1:"E")
End DoDot:3
End DoDot:2
End DoDot:1
+33 SET DATA=RET
+34 QUIT
+35 ; Returns ability of user to e-prescribe
+36 ; Input: USR - IEN to New Person File
+37 ; Output: 0 = e-Prescribing is not available to user
+38 ; 1 = e-Prescribing is available to user
ERXUSER(USR) ; EP
+1 NEW RET
+2 DO ERXUSER^APSPFNC2(.RET,USR)
+3 QUIT RET
+4 ; Returns match of orderable item to drug schedule
+5 ; Input: OIIEN - Orderable Item IEN
+6 ; SCH - SCHEDULE
+7 ; TPL - Invert return value
ERXOI(OIIEN,SCH,TPL) ; EP
+1 NEW RET
+2 SET TPL=+$GET(TPL,0)
+3 DO ERXOI^APSPFNC2(.RET,OIIEN,SCH)
+4 QUIT $SELECT(TPL:RET,1:'RET)
+5 ; Retransmit eRX order
+6 ; Input: ORD - IEN to Order File (100)
+7 ; Output: 1 = resent
RESEND(DATA,ORD,RXNUM) ;EP -
+1 NEW PHARM,RX
+2 SET PHARM=+$$VALUE^ORCSAVE2(+ORD,"PHARMACY")
+3 SET RX=+$GET(^OR(100,ORD,4))
+4 IF $PIECE($GET(^PSRX(RX,0)),U)=RXNUM
Begin DoDot:1
+5 DO EN^APSPELRX(RX,PHARM)
End DoDot:1
+6 SET DATA=1
+7 QUIT
+8 ; Returns boolean value representing presence of reason and type in activity log.
CKRXACT(RX,REASON,TYPE) ;EP-
+1 NEW RES,LP,PR,PT
+2 SET (LP,RES)=0
+3 IF '$GET(RX)
QUIT RES
+4 IF '$LENGTH($GET(REASON))
QUIT RES
+5 SET TYPE=$GET(TYPE)
+6 FOR
SET LP=$ORDER(^PSRX(RX,"A",LP))
IF 'LP
QUIT
Begin DoDot:1
+7 SET PR=$PIECE(^PSRX(RX,"A",LP,0),U,2)
+8 IF PR'=REASON
QUIT
+9 SET PT=$PIECE($GET(^PSRX(RX,"A",LP,9999999)),U,2)
+10 IF PT=""
QUIT
+11 IF TYPE[PT
SET RES=1
End DoDot:1
IF RES
QUIT
+12 QUIT RES
+13 ;Returns if this drug is OK to send as a eRX
OKTOUSE(OI,RSCH) ;function call
+1 NEW RES,IEN,STOP,POI,NODE
+2 SET RES=1
+3 IF $LENGTH(RSCH)&($$ERXOI(OI,RSCH))
QUIT 0
+4 SET POI=$PIECE($PIECE($GET(^ORD(101.43,OI,0)),U,2),";",1)
+5 IF POI=""
QUIT RES
+6 SET IEN=""
FOR
SET IEN=$ORDER(^PSDRUG("ASP",POI,IEN))
IF IEN=""!(RES=0)
QUIT
Begin DoDot:1
+7 SET NODE=$GET(^PSDRUG(IEN,0))
+8 IF NODE=""
QUIT
+9 IF $PIECE($GET(^PSDRUG(IEN,999999935)),U,3)=1
SET RES=0
+10 IF $$ERXONLY(IEN)
SET RES=2
End DoDot:1
+11 QUIT RES
CHKERX(ORDER) ;Find out if ORDER was an eRX one
+1 NEW VALUE,RX
+2 SET VALUE=0
SET ORDER=$PIECE(ORDER,";")
+3 SET RX=""
SET RX=$ORDER(^PSRX("APL",ORDER,RX))
+4 IF RX=""
QUIT VALUE
+5 SET VALUE=+$$GET1^DIQ(52,RX,9999999.23,"I")
+6 QUIT VALUE
+7 ; Return ERX only of drug
+8 ; Input: Order File IEN
+9 ; Output: Boolean
ERXONLY(DRUG) ;EP- Patch 1021
+1 NEW VAL
+2 SET VAL=$PIECE($GET(^PSDRUG(DRUG,999999935)),U,3)
+3 QUIT VAL=2
+4 ; Return long name of drug
+5 ; Input: Order File IEN
GETLONG(RET,ORDER) ;EP-
+1 NEW DRUG
+2 SET RET=""
+3 SET DRUG=$$VALUE^ORCSAVE2(ORDER,"DRUG")
+4 IF '+DRUG
QUIT
+5 SET RET=$$GETLNGDG(DRUG)
+6 QUIT
+7 ; Return long name of drug
+8 ; Input: Drug File IEN
GETLNGDG(DRUG) ;EP-
+1 QUIT $$GET1^DIQ(50,DRUG,9999999.352)
+2 ;
+3 ; Find a site
LOC(ORIEN) ;
+1 NEW PSOLOC,PSOINS,PSOSITE
+2 SET PSOLOC=$PIECE($GET(^OR(100,ORIEN,0)),U,10)
+3 SET PSOSITE=$$GET^XPAR("LOC.`"_PSOLOC_U_"DIV.`"_DUZ(2)_"^SYS","APSP AUTO RX DIV")
+4 IF 'PSOSITE
Begin DoDot:1
+5 SET PSOSITE=0
+6 IF PSOLOC["SC"
Begin DoDot:2
+7 SET PSOLOC=+PSOLOC
+8 SET PSOINS=$PIECE($GET(^SC(PSOLOC,0)),U,4)
+9 IF 'PSOINS
QUIT
+10 SET PSOSITE=$$DIV(PSOINS)
End DoDot:2
+11 IF 'PSOSITE
SET PSOSITE=$$DIV(DUZ(2))
+12 IF 'PSOSITE
SET PSOSITE=$$DIV(+$$SITE^VASITE)
End DoDot:1
+13 QUIT $SELECT($GET(PSOSITE):PSOSITE,1:0)
+14 ; This screen is used by the APSP AUTO RX DIV parameter.
+15 ; Input: DIV - Pointer to Institution (4) file
DIVSCN(ENT) ;
+1 IF $GET(ENT)["DIC(4,"
QUIT ''$$DIV(+ENT)
+2 IF $GET(ENT)["DIC(4.2,"
QUIT 1
+3 IF $GET(ENT)["SC("
QUIT 1
+4 QUIT 0
+5 ; Return Pharmacy Division
DIV(INS) QUIT $ORDER(^PS(59,"D",+INS,0))
+1 ;
+2 ; Returns the last activity type for requested reason
LASTACT(RX,REASON) ;EP-
+1 NEW RES,LP,PR,PT,FLG
+2 SET FLG=0
SET RES=""
+3 SET LP=$CHAR(1)
+4 IF '$GET(RX)
QUIT RES
+5 IF '$LENGTH($GET(REASON))
QUIT RES
+6 FOR
SET LP=$ORDER(^PSRX(RX,"A",LP),-1)
IF 'LP
QUIT
Begin DoDot:1
+7 SET PR=$PIECE(^PSRX(RX,"A",LP,0),U,2)
+8 IF PR'=REASON
QUIT
+9 SET FLG=1
+10 SET RES=$PIECE($GET(^PSRX(RX,"A",LP,9999999)),U,2)
End DoDot:1
IF FLG
QUIT
+11 QUIT RES
