APSPPCC1 ;IHS/CIA/PLS - PCC Hook for Pharmacy Package - Continued ;04-Jun-2014 14:48;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1005,1007,1009,1010,1013,1017,1018**;Sep 23, 2004;Build 21
; Modified - IHS/MSC/PLS - 02/05/08 - POV API modified
; 08/25/10 - SET+1
; 02/10/11 - EN and new EN1 EP
; Prompt and store POV value in APSP POV CACHE parameter
EN(DFN,RXIEN,SUS) ;EP
;Q ;IHS/MSC/PLS - 05/16/2013 - POV Functionality disabled per CR368
;IHS/MSC/PLS - 06/03/2014 - Added hard set of ICD code into XPAR parameter
I $$GET1^DIQ(9009033,+$G(PSOSITE),405,"I") D
.N POV,RFIEN,IMP
.S RFIEN=$O(^PSRX(RXIEN,1,$C(1)),-1)
.Q:'$G(SUS)&('RFIEN)
.Q:$L($$GET^XPAR("SYS","APSP POV CACHE",+RXIEN_","_+RFIEN)) ; already have a POV stored
.I $$VERSION^XPDUTL("AICD")<4.0 S POV="V68.1"
.E D
..S IMP=$$IMP^ICDEX("10D",DT)
..I DT<IMP S POV="V68.1"
..E S POV="Z76.0"
.D SET(RXIEN,RFIEN,POV)
Q
I $$GET1^DIQ(9009033,+$G(PSOSITE),405,"I") D
.W !!,"Processing POV entry for prescription...",!
.D EN1
E I $G(SUS) D
.Q:'$$GET1^DIQ(9009033,+$G(PSOSITE),402,"I")
.W !!,"Processing POV entry for suspense...",!
.D EN1
E I $$GET1^DIQ(9009033,+$G(PSOSITE),315,"I") D
.Q:'RFIEN ; Must have a refill
.Q:'$$CONFIRM("Is this a Pharmacy Only Visit (Paperless refill)?",1)
.W !!,"Processing paperless refill...",!
.D EN1
Q
EN1 ;EP - Prompt user
W !,"Rx# "_$P($G(^PSRX(RXIEN,0)),U,1)," Drug:",$P($G(^PSDRUG(+$P($G(^PSRX(RXIEN,0)),U,6),0)),U),!
S POV=$$POV(RXIEN,RFIEN)
D SET(RXIEN,RFIEN,POV)
Q
; Prompt and store POV value in cache
; Input: RXIEN - Prescription IEN
; RFIEN - Refill IEN under Prescription IEN
POV(RXIEN,RFIEN) ;
N RXVMED,POV,VIS,CLININD,SIGN
S POV=""
; Check for Indication Code - IHS/MSC/PLS - 02/05/08 - Added lookup of Sign/Indication Code if available.
S SIGN=$P($G(^PSRX(RXIEN,999999921)),U)
S CLININD=$P($G(^PSRX(RXIEN,999999921)),U,2)
I $L(CLININD) D Q:$L(POV) POV
.W !,"Do you wish to use the Sign/Symptom associated with the prescription?",!
.S X=CLININD,DIC=80,DIC(0)="EMQ" D ^DIC
.I $G(Y)>0 D
..S POV=$P(Y,U,2)_U_$$PRVNARR^APSPPCC($S($L(SIGN):SIGN,1:$$GET1^DIQ(80,+Y,3)))
;
S RXVMED=$$GETVMED(RXIEN)
I 'RXVMED D
.S POV=$$ACTPROB(RXIEN)
.S:'$L(POV) POV=$$PROVNAR
E D
.S VIS=+$$GET1^DIQ(9000010.14,RXVMED,.03,"I")
.I '$D(^AUPNVSIT(VIS,0)) D
..S POV=$$ACTPROB(RXIEN)
..S:'$L(POV) POV=$$PROVNAR
.E I '$D(^AUPNVPOV("AD",VIS)) D
..S POV=$$ACTPROB(RXIEN)
..S:'$L(POV) POV=$$PROVNAR
.E D
..S POV=$$POVS(VIS)
..S:'$L(POV) POV=$$ACTPROB(RXIEN)
..S:'$L(POV) POV=$$PROVNAR
Q POV
;
; Prompt for Active Problem List
; List is restrict to Problems with Active ICD9 Codes
ACTPROB(RXIEN) ;
N POV,CNT,PRB,PIEN,DFN,DIR,DUOUT,DIRUT,DTOUT,ICDIEN
S POV=""
S DFN=+$$GET1^DIQ(52,RXIEN,2,"I")
I $D(^AUPNPROB("AC",DFN)) D
.W !,"Problem list:"
.S (PIEN,CNT)=0 F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D
..Q:$$GET1^DIQ(80,+$$GET1^DIQ(9000011,PIEN,.01,"I"),100,"I") ;Quit if Inactive
..S CNT=CNT+1 W !?5,CNT,")",?8,$$GET1^DIQ(9000011,PIEN,.01),?15,$$GET1^DIQ(9000011,PIEN,.05) S PRB(CNT)=PIEN
.I CNT>0 D
..S DIR(0)="N^1:"_CNT_":0",DIR("A")="Please select the appropriate Problem List diagnosis for the drug prescribed."
..D ^DIR
..I '$D(DIRUT) D
...S PIEN=PRB(+Y)
...S POV=$$ICD(+$P(^AUPNPROB(PIEN,0),U))_U_+$P(^AUPNPROB(PIEN,0),U,5)
Q POV
; Prompt for provider narrative
PROVNAR() ;
N POV,DIR,DUOUT,DIRUT,DTOUT
S POV=""
W !,"Please enter a narrative describing the diagnosis."
S DIR("A")="Diagnosis Narrative",DIR(0)="9000010.07,.04" D ^DIR
I '$D(DIRUT) D
.S POV=".9999"_U_+Y
E S POV="999.9"_U_$$PRVNARR^APSPPCC("MEDICATION REFILL")
Q POV
; Prompt for existing purpose of visit
POVS(VIEN) ;
N POV,POVS,DIR,DUOUT,DIRUT,DTOUT,CNT,PIEN
S (CNT,PIEN)=0,POV=""
W !,"Purpose of Visit List:"
F S PIEN=$O(^AUPNVPOV("AD",VIEN,PIEN)) Q:'PIEN D
.Q:$$POVSEL(PIEN) ; Screen POVs
.S CNT=CNT+1 W !?5,CNT,")",?8,$$GET1^DIQ(9000010.07,PIEN,.01),?15,$$GET1^DIQ(9000010.07,PIEN,.04) S POVS(CNT)=PIEN
I CNT>0 D
.S DIR(0)="N^1:"_CNT_":0",DIR("A")="Please select the appropriate diagnosis for the drug prescribed."
.S DIR("B")=1
.S DIR("?")="Select a number or enter ^ for more choices."
.D ^DIR
.I '$D(DIRUT) D
..S PIEN=POVS(+Y)
..S POV=$$ICD(+$P(^AUPNVPOV(PIEN,0),U))_U_+$P(^AUPNVPOV(PIEN,0),U,4)
Q POV
; Return ICD Code for given IEN
ICD(IEN) ;
Q $S($$GET1^DIQ(80,+IEN,100,"I"):".9999",1:$$GET1^DIQ(80,+IEN,.01))
; Return code selection status
; Output: 0 - Code is selectable
; 1 - Code is NOT selectable
POVSEL(PIEN) ;EP
N RES
S RES=+$$GET1^DIQ(80,+$$GET1^DIQ(9000010.07,PIEN,.01,"I"),100,"I") ; Check for Inactive flag
S RES=RES!($$GET1^DIQ(9000010.07,PIEN,.01)="V68.1") ; Exclude from selection
Q RES
; Set data into XTMP global node
SET(RXIEN,RFIEN,POV) ;
;IHS/MSC/PLS - 08/25/2010 - Changed to cache POV in parameter
D ADD^XPAR("SYS","APSP POV CACHE",+RXIEN_","_+RFIEN,$TR(POV,U,"~"))
;L +^XTMP("APSPPCC.VPOV"):2
;S ^XTMP("APSPPCC.VPOV",0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT
;S ^XTMP("APSPPCC.VPOV",RXIEN,RFIEN)=POV
;L -^XTMP("APSPPCC.VPOV")
Q
; Confirm
CONFIRM(PROMPT,DEFAULT) ; EP
N DIR
S DIR("A")=$G(PROMPT)
S DIR(0)="Y",DIR("B")=$S(+$G(DEFAULT):"Yes",1:"No")
D ^DIR
Q Y>0
;Return VMED pointer
GETVMED(RXIEN) ;EP
N RES
;First try to return the VMED for the first refill.
S RES=+$$GET1^DIQ(52.1,"1,"_RXIEN_",",9999999.11,"I")
Q:RES RES
;Otherwise return VMED for the prescription
Q +$$GET1^DIQ(52,RXIEN,9999999.11,"I")
APSPPCC1 ;IHS/CIA/PLS - PCC Hook for Pharmacy Package - Continued ;04-Jun-2014 14:48;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1005,1007,1009,1010,1013,1017,1018**;Sep 23, 2004;Build 21
+2 ; Modified - IHS/MSC/PLS - 02/05/08 - POV API modified
+3 ; 08/25/10 - SET+1
+4 ; 02/10/11 - EN and new EN1 EP
+5 ; Prompt and store POV value in APSP POV CACHE parameter
EN(DFN,RXIEN,SUS) ;EP
+1 ;Q ;IHS/MSC/PLS - 05/16/2013 - POV Functionality disabled per CR368
+2 ;IHS/MSC/PLS - 06/03/2014 - Added hard set of ICD code into XPAR parameter
+3 IF $$GET1^DIQ(9009033,+$GET(PSOSITE),405,"I")
Begin DoDot:1
+4 NEW POV,RFIEN,IMP
+5 SET RFIEN=$ORDER(^PSRX(RXIEN,1,$CHAR(1)),-1)
+6 IF '$GET(SUS)&('RFIEN)
QUIT
+7 ; already have a POV stored
IF $LENGTH($$GET^XPAR("SYS","APSP POV CACHE",+RXIEN_","_+RFIEN))
QUIT
+8 IF $$VERSION^XPDUTL("AICD")<4.0
SET POV="V68.1"
+9 IF '$TEST
Begin DoDot:2
+10 SET IMP=$$IMP^ICDEX("10D",DT)
+11 IF DT<IMP
SET POV="V68.1"
+12 IF '$TEST
SET POV="Z76.0"
End DoDot:2
+13 DO SET(RXIEN,RFIEN,POV)
End DoDot:1
+14 QUIT
+15 IF $$GET1^DIQ(9009033,+$GET(PSOSITE),405,"I")
Begin DoDot:1
+16 WRITE !!,"Processing POV entry for prescription...",!
+17 DO EN1
End DoDot:1
+18 IF '$TEST
IF $GET(SUS)
Begin DoDot:1
+19 IF '$$GET1^DIQ(9009033,+$GET(PSOSITE),402,"I")
QUIT
+20 WRITE !!,"Processing POV entry for suspense...",!
+21 DO EN1
End DoDot:1
+22 IF '$TEST
IF $$GET1^DIQ(9009033,+$GET(PSOSITE),315,"I")
Begin DoDot:1
+23 ; Must have a refill
IF 'RFIEN
QUIT
+24 IF '$$CONFIRM("Is this a Pharmacy Only Visit (Paperless refill)?",1)
QUIT
+25 WRITE !!,"Processing paperless refill...",!
+26 DO EN1
End DoDot:1
+27 QUIT
EN1 ;EP - Prompt user
+1 WRITE !,"Rx# "_$PIECE($GET(^PSRX(RXIEN,0)),U,1)," Drug:",$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(RXIEN,0)),U,6),0)),U),!
+2 SET POV=$$POV(RXIEN,RFIEN)
+3 DO SET(RXIEN,RFIEN,POV)
+4 QUIT
+5 ; Prompt and store POV value in cache
+6 ; Input: RXIEN - Prescription IEN
+7 ; RFIEN - Refill IEN under Prescription IEN
POV(RXIEN,RFIEN) ;
+1 NEW RXVMED,POV,VIS,CLININD,SIGN
+2 SET POV=""
+3 ; Check for Indication Code - IHS/MSC/PLS - 02/05/08 - Added lookup of Sign/Indication Code if available.
+4 SET SIGN=$PIECE($GET(^PSRX(RXIEN,999999921)),U)
+5 SET CLININD=$PIECE($GET(^PSRX(RXIEN,999999921)),U,2)
+6 IF $LENGTH(CLININD)
Begin DoDot:1
+7 WRITE !,"Do you wish to use the Sign/Symptom associated with the prescription?",!
+8 SET X=CLININD
SET DIC=80
SET DIC(0)="EMQ"
DO ^DIC
+9 IF $GET(Y)>0
Begin DoDot:2
+10 SET POV=$PIECE(Y,U,2)_U_$$PRVNARR^APSPPCC($SELECT($LENGTH(SIGN):SIGN,1:$$GET1^DIQ(80,+Y,3)))
End DoDot:2
End DoDot:1
IF $LENGTH(POV)
QUIT POV
+11 ;
+12 SET RXVMED=$$GETVMED(RXIEN)
+13 IF 'RXVMED
Begin DoDot:1
+14 SET POV=$$ACTPROB(RXIEN)
+15 IF '$LENGTH(POV)
SET POV=$$PROVNAR
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET VIS=+$$GET1^DIQ(9000010.14,RXVMED,.03,"I")
+18 IF '$DATA(^AUPNVSIT(VIS,0))
Begin DoDot:2
+19 SET POV=$$ACTPROB(RXIEN)
+20 IF '$LENGTH(POV)
SET POV=$$PROVNAR
End DoDot:2
+21 IF '$TEST
IF '$DATA(^AUPNVPOV("AD",VIS))
Begin DoDot:2
+22 SET POV=$$ACTPROB(RXIEN)
+23 IF '$LENGTH(POV)
SET POV=$$PROVNAR
End DoDot:2
+24 IF '$TEST
Begin DoDot:2
+25 SET POV=$$POVS(VIS)
+26 IF '$LENGTH(POV)
SET POV=$$ACTPROB(RXIEN)
+27 IF '$LENGTH(POV)
SET POV=$$PROVNAR
End DoDot:2
End DoDot:1
+28 QUIT POV
+29 ;
+30 ; Prompt for Active Problem List
+31 ; List is restrict to Problems with Active ICD9 Codes
ACTPROB(RXIEN) ;
+1 NEW POV,CNT,PRB,PIEN,DFN,DIR,DUOUT,DIRUT,DTOUT,ICDIEN
+2 SET POV=""
+3 SET DFN=+$$GET1^DIQ(52,RXIEN,2,"I")
+4 IF $DATA(^AUPNPROB("AC",DFN))
Begin DoDot:1
+5 WRITE !,"Problem list:"
+6 SET (PIEN,CNT)=0
FOR
SET PIEN=$ORDER(^AUPNPROB("AC",DFN,PIEN))
IF 'PIEN
QUIT
Begin DoDot:2
+7 ;Quit if Inactive
IF $$GET1^DIQ(80,+$$GET1^DIQ(9000011,PIEN,.01,"I"),100,"I")
QUIT
+8 SET CNT=CNT+1
WRITE !?5,CNT,")",?8,$$GET1^DIQ(9000011,PIEN,.01),?15,$$GET1^DIQ(9000011,PIEN,.05)
SET PRB(CNT)=PIEN
End DoDot:2
+9 IF CNT>0
Begin DoDot:2
+10 SET DIR(0)="N^1:"_CNT_":0"
SET DIR("A")="Please select the appropriate Problem List diagnosis for the drug prescribed."
+11 DO ^DIR
+12 IF '$DATA(DIRUT)
Begin DoDot:3
+13 SET PIEN=PRB(+Y)
+14 SET POV=$$ICD(+$PIECE(^AUPNPROB(PIEN,0),U))_U_+$PIECE(^AUPNPROB(PIEN,0),U,5)
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT POV
+16 ; Prompt for provider narrative
PROVNAR() ;
+1 NEW POV,DIR,DUOUT,DIRUT,DTOUT
+2 SET POV=""
+3 WRITE !,"Please enter a narrative describing the diagnosis."
+4 SET DIR("A")="Diagnosis Narrative"
SET DIR(0)="9000010.07,.04"
DO ^DIR
+5 IF '$DATA(DIRUT)
Begin DoDot:1
+6 SET POV=".9999"_U_+Y
End DoDot:1
+7 IF '$TEST
SET POV="999.9"_U_$$PRVNARR^APSPPCC("MEDICATION REFILL")
+8 QUIT POV
+9 ; Prompt for existing purpose of visit
POVS(VIEN) ;
+1 NEW POV,POVS,DIR,DUOUT,DIRUT,DTOUT,CNT,PIEN
+2 SET (CNT,PIEN)=0
SET POV=""
+3 WRITE !,"Purpose of Visit List:"
+4 FOR
SET PIEN=$ORDER(^AUPNVPOV("AD",VIEN,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+5 ; Screen POVs
IF $$POVSEL(PIEN)
QUIT
+6 SET CNT=CNT+1
WRITE !?5,CNT,")",?8,$$GET1^DIQ(9000010.07,PIEN,.01),?15,$$GET1^DIQ(9000010.07,PIEN,.04)
SET POVS(CNT)=PIEN
End DoDot:1
+7 IF CNT>0
Begin DoDot:1
+8 SET DIR(0)="N^1:"_CNT_":0"
SET DIR("A")="Please select the appropriate diagnosis for the drug prescribed."
+9 SET DIR("B")=1
+10 SET DIR("?")="Select a number or enter ^ for more choices."
+11 DO ^DIR
+12 IF '$DATA(DIRUT)
Begin DoDot:2
+13 SET PIEN=POVS(+Y)
+14 SET POV=$$ICD(+$PIECE(^AUPNVPOV(PIEN,0),U))_U_+$PIECE(^AUPNVPOV(PIEN,0),U,4)
End DoDot:2
End DoDot:1
+15 QUIT POV
+16 ; Return ICD Code for given IEN
ICD(IEN) ;
+1 QUIT $SELECT($$GET1^DIQ(80,+IEN,100,"I"):".9999",1:$$GET1^DIQ(80,+IEN,.01))
+2 ; Return code selection status
+3 ; Output: 0 - Code is selectable
+4 ; 1 - Code is NOT selectable
POVSEL(PIEN) ;EP
+1 NEW RES
+2 ; Check for Inactive flag
SET RES=+$$GET1^DIQ(80,+$$GET1^DIQ(9000010.07,PIEN,.01,"I"),100,"I")
+3 ; Exclude from selection
SET RES=RES!($$GET1^DIQ(9000010.07,PIEN,.01)="V68.1")
+4 QUIT RES
+5 ; Set data into XTMP global node
SET(RXIEN,RFIEN,POV) ;
+1 ;IHS/MSC/PLS - 08/25/2010 - Changed to cache POV in parameter
+2 DO ADD^XPAR("SYS","APSP POV CACHE",+RXIEN_","_+RFIEN,$TRANSLATE(POV,U,"~"))
+3 ;L +^XTMP("APSPPCC.VPOV"):2
+4 ;S ^XTMP("APSPPCC.VPOV",0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT
+5 ;S ^XTMP("APSPPCC.VPOV",RXIEN,RFIEN)=POV
+6 ;L -^XTMP("APSPPCC.VPOV")
+7 QUIT
+8 ; Confirm
CONFIRM(PROMPT,DEFAULT) ; EP
+1 NEW DIR
+2 SET DIR("A")=$GET(PROMPT)
+3 SET DIR(0)="Y"
SET DIR("B")=$SELECT(+$GET(DEFAULT):"Yes",1:"No")
+4 DO ^DIR
+5 QUIT Y>0
+6 ;Return VMED pointer
GETVMED(RXIEN) ;EP
+1 NEW RES
+2 ;First try to return the VMED for the first refill.
+3 SET RES=+$$GET1^DIQ(52.1,"1,"_RXIEN_",",9999999.11,"I")
+4 IF RES
QUIT RES
+5 ;Otherwise return VMED for the prescription
+6 QUIT +$$GET1^DIQ(52,RXIEN,9999999.11,"I")
