- 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