BEHORXED ;MSC/IND/PLS - PharmED Component Support ;06-Nov-2014 10:14;DU
;;1.1;BEH COMPONENTS;**044002,044004,044005**;Mar 20, 2007
;=========================================================
; Return list of selectable POVs
POVLST(DATA) ;EP
N TMP,LP,POV,NTMP,SNMD,SNMDC,MICD
;D GETLST^XPAR(.TMP,"ALL","BEHORXED POV LIST","B")
;D GETLST^XPAR(.NTMP,"ALL","BEHORXED POV NARR TEXT","I")
;Retrieve SNOMED Concept IDs
D GETLST^XPAR(.TMP,"ALL","BEHORXED POV SNOMED LIST","B")
S LP=0 F S LP=$O(TMP(LP)) Q:'LP D
.S SNMD=$G(TMP(LP,"V"))
.Q:'SNMD
.;IHS/MSC/MGH Changed to use new API
.;S SNMDC=$$CONC^BSTSAPI(+SNMD_"^^^1")
.S SNMDC=$$CONC^AUPNSICD(+SNMD_"^^^1")
.S MICD=$$GET^XPAR("ALL","BEHORXED POV MAP ICD",LP,"E")
.Q:$P(SNMDC,U,5)=""&(MICD="")
.;S DATA(LP)=POV_U_$$GET1^DIQ(80,+POV,3)_U_$G(NTMP(LP))
.S DATA(LP)=+SNMD_U_$S($L(MICD):MICD,1:$P($P(SNMDC,U,5),";",1))_U_$P(SNMDC,U,4)
Q
; Return list of selectable Education Topics
EDLST(DATA) ;EP
N TMP,LP,ED
D GETLST^XPAR(.TMP,"ALL","BEHORXED EDUCATION TOPICS LIST","B")
S LP=0 F S LP=$O(TMP(LP)) Q:'LP D
.S ED=$G(TMP(LP,"V"))
.Q:'ED
.S DATA(LP)=ED
Q
COMPLST(DATA) ;EP
N TMP,VAL,SET
D FIELD^DID(9000010.16,.06,"","POINTER","TMP")
S SET=$G(TMP("POINTER"))
I $L(SET) D
.S LP=1 F S VAL=$P(SET,";",LP) Q:'VAL D S LP=LP+1
..S DATA(LP)=VAL
Q
; Store PED data
STORE(DATA,DFN,VSTR,PCCARY) ;EP
; PED^Code^Cat^Nar^Com^prv^level of understanding^refused^elapsed^setting^goals^outcome
N LP
;S LP=0 F S LP=$O(PCCARY(LP)) Q:'LP D
;.I PCCARY(LP)["POV" K PCCARY(LP)
D SAVE^BEHOENPC(.DATA,.PCCARY)
D:DATA=0 XTMPSET(DFN,DT)
Q
; Provider Narrative RPC
PRVNRPC(DATA,TXT) ;
S DATA=$$PRVNARR(TXT)
Q
; Return Provider Narrative IEN
PRVNARR(TXT) ; EP
N IEN,FDA,IENS,ERR,TRC
Q:'$L(TXT) ""
S TXT=$E(TXT,1,80),TRC=$E(TXT,1,30),IEN=0
F S IEN=$O(^AUTNPOV("B",TRC,IEN)) Q:'IEN Q:$P($G(^AUTNPOV(IEN,0)),U)=TXT
I 'IEN D
.S FDA(9999999.27,"+1,",.01)=TXT
.D UPDATE^DIE("","FDA","IENS","ERR")
.I $G(ERR) S IEN=""
.E S IEN=$G(IENS(1))
Q IEN
; Return use status of PharmEd component
CANUSE(DATA,DFN) ;EP
S DATA='$G(^XTMP("BEHORXED",DT,DFN))
D CLEANUP(DT)
Q
;
XTMPSET(DFN,DATE) ;EP
I '$D(^XTMP("BEHORXED",DATE)) D
.S ^XTMP("BEHORXED",0)=$$FMADD^XLFDT(DT,+7)_U_DT_U_"PharmED component"
S ^XTMP("BEHORXED",DATE,DFN)=1
D BRDCAST^CIANBEVT("PCC.PHARMED."_DFN)
Q
; Cleanup the XTMP global
CLEANUP(DATE) ;
N LP,EDT
Q:$D(^XTMP("BEHORXED",DATE)) ; already purged
S EDT=$$FMADD^XLFDT(DATE,-1)
S LP=0 F S LP=$O(^XTMP("BEHORXED",LP)) Q:'LP!(LP>EDT) D
.K ^XTMP("BEHORXED",LP)
Q
; Return list of available visits
VSTLST(DATA,DFN,SDT,CAT) ;EP
N EDT,IN,VST,IDT,IDT2,VIEN,NODE0,CNT,LOCNAM,LOCIEN,VDATE,VSTR,STS
S:'$G(SDT) SDT=DT
S EDT=SDT+.9
S CAT=$G(CAT,"A") ;Default to Ambulatory visits
S DATA=$$TMPGBL^CIAVMRPC
S IDT2=9999999-(SDT\1)+.9,IDT=9999999-(EDT\1)
S CNT=0
F Q:'IDT!(IDT>IDT2) D S IDT=$O(^AUPNVSIT("AA",DFN,IDT))
.S VIEN=0 F S VIEN=$O(^AUPNVSIT("AA",DFN,IDT,VIEN)) Q:'VIEN D
..N PRV
..S NODE0=^AUPNVSIT(VIEN,0)
..Q:$P(NODE0,U,11) ; Ignore visits that are logically deleted
..Q:$P(NODE0,U,7)'=CAT ; Compare Service Category
..Q:$$ISLOCKED^BEHOENCX(VIEN) ; Ignore logically deleted visits
..S VDATE=+NODE0,LOCIEN=$P(NODE0,U,22),LOCNAM=$$GET1^DIQ(44,LOCIEN,.01)
..S VSTR=LOCIEN_";"_VDATE_";"_CAT_";"_VIEN
..S STS=$$SET^CIAU(CAT,$P($G(^DD(9000010,.07,0)),U,3))
..D GETPRV2^BEHOENCX(.PRV,VIEN,1)
..S PRV=$P($G(PRV(+$O(PRV(0)))),U,1,2)
..S CNT=CNT+1,@DATA@(-VDATE,CNT)=VSTR_U_LOCNAM_U_VDATE_U_STS_U_U_PRV
Q
; Post-init logic
POST ;EP-
N OPT
F OPT="BEHORXED DEFAULT POV","BEHORXED POV LIST","BEHORXED POV NARR TEXT" D OUT^XPDMENU(OPT,"Not currently used."),UPDPAR("SYS",OPT)
Q
UPDPAR(ENT,PARAM,VAL) ;EP-
N IEN
S IEN=$O(^XTV(8989.51,"B",PARAM,0))
Q:'IEN
S $P(^XTV(8989.51,IEN,0),U,6)=0
D:$G(VAL)'="" EN^XPAR(ENT,PARAM,,VAL)
S $P(^XTV(8989.51,IEN,0),U,6)=1
Q
BEHORXED ;MSC/IND/PLS - PharmED Component Support ;06-Nov-2014 10:14;DU
+1 ;;1.1;BEH COMPONENTS;**044002,044004,044005**;Mar 20, 2007
+2 ;=========================================================
+3 ; Return list of selectable POVs
POVLST(DATA) ;EP
+1 NEW TMP,LP,POV,NTMP,SNMD,SNMDC,MICD
+2 ;D GETLST^XPAR(.TMP,"ALL","BEHORXED POV LIST","B")
+3 ;D GETLST^XPAR(.NTMP,"ALL","BEHORXED POV NARR TEXT","I")
+4 ;Retrieve SNOMED Concept IDs
+5 DO GETLST^XPAR(.TMP,"ALL","BEHORXED POV SNOMED LIST","B")
+6 SET LP=0
FOR
SET LP=$ORDER(TMP(LP))
IF 'LP
QUIT
Begin DoDot:1
+7 SET SNMD=$GET(TMP(LP,"V"))
+8 IF 'SNMD
QUIT
+9 ;IHS/MSC/MGH Changed to use new API
+10 ;S SNMDC=$$CONC^BSTSAPI(+SNMD_"^^^1")
+11 SET SNMDC=$$CONC^AUPNSICD(+SNMD_"^^^1")
+12 SET MICD=$$GET^XPAR("ALL","BEHORXED POV MAP ICD",LP,"E")
+13 IF $PIECE(SNMDC,U,5)=""&(MICD="")
QUIT
+14 ;S DATA(LP)=POV_U_$$GET1^DIQ(80,+POV,3)_U_$G(NTMP(LP))
+15 SET DATA(LP)=+SNMD_U_$SELECT($LENGTH(MICD):MICD,1:$PIECE($PIECE(SNMDC,U,5),";",1))_U_$PIECE(SNMDC,U,4)
End DoDot:1
+16 QUIT
+17 ; Return list of selectable Education Topics
EDLST(DATA) ;EP
+1 NEW TMP,LP,ED
+2 DO GETLST^XPAR(.TMP,"ALL","BEHORXED EDUCATION TOPICS LIST","B")
+3 SET LP=0
FOR
SET LP=$ORDER(TMP(LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET ED=$GET(TMP(LP,"V"))
+5 IF 'ED
QUIT
+6 SET DATA(LP)=ED
End DoDot:1
+7 QUIT
COMPLST(DATA) ;EP
+1 NEW TMP,VAL,SET
+2 DO FIELD^DID(9000010.16,.06,"","POINTER","TMP")
+3 SET SET=$GET(TMP("POINTER"))
+4 IF $LENGTH(SET)
Begin DoDot:1
+5 SET LP=1
FOR
SET VAL=$PIECE(SET,";",LP)
IF 'VAL
QUIT
Begin DoDot:2
+6 SET DATA(LP)=VAL
End DoDot:2
SET LP=LP+1
End DoDot:1
+7 QUIT
+8 ; Store PED data
STORE(DATA,DFN,VSTR,PCCARY) ;EP
+1 ; PED^Code^Cat^Nar^Com^prv^level of understanding^refused^elapsed^setting^goals^outcome
+2 NEW LP
+3 ;S LP=0 F S LP=$O(PCCARY(LP)) Q:'LP D
+4 ;.I PCCARY(LP)["POV" K PCCARY(LP)
+5 DO SAVE^BEHOENPC(.DATA,.PCCARY)
+6 IF DATA=0
DO XTMPSET(DFN,DT)
+7 QUIT
+8 ; Provider Narrative RPC
PRVNRPC(DATA,TXT) ;
+1 SET DATA=$$PRVNARR(TXT)
+2 QUIT
+3 ; Return Provider Narrative IEN
PRVNARR(TXT) ; EP
+1 NEW IEN,FDA,IENS,ERR,TRC
+2 IF '$LENGTH(TXT)
QUIT ""
+3 SET TXT=$EXTRACT(TXT,1,80)
SET TRC=$EXTRACT(TXT,1,30)
SET IEN=0
+4 FOR
SET IEN=$ORDER(^AUTNPOV("B",TRC,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(^AUTNPOV(IEN,0)),U)=TXT
QUIT
+5 IF 'IEN
Begin DoDot:1
+6 SET FDA(9999999.27,"+1,",.01)=TXT
+7 DO UPDATE^DIE("","FDA","IENS","ERR")
+8 IF $GET(ERR)
SET IEN=""
+9 IF '$TEST
SET IEN=$GET(IENS(1))
End DoDot:1
+10 QUIT IEN
+11 ; Return use status of PharmEd component
CANUSE(DATA,DFN) ;EP
+1 SET DATA='$GET(^XTMP("BEHORXED",DT,DFN))
+2 DO CLEANUP(DT)
+3 QUIT
+4 ;
XTMPSET(DFN,DATE) ;EP
+1 IF '$DATA(^XTMP("BEHORXED",DATE))
Begin DoDot:1
+2 SET ^XTMP("BEHORXED",0)=$$FMADD^XLFDT(DT,+7)_U_DT_U_"PharmED component"
End DoDot:1
+3 SET ^XTMP("BEHORXED",DATE,DFN)=1
+4 DO BRDCAST^CIANBEVT("PCC.PHARMED."_DFN)
+5 QUIT
+6 ; Cleanup the XTMP global
CLEANUP(DATE) ;
+1 NEW LP,EDT
+2 ; already purged
IF $DATA(^XTMP("BEHORXED",DATE))
QUIT
+3 SET EDT=$$FMADD^XLFDT(DATE,-1)
+4 SET LP=0
FOR
SET LP=$ORDER(^XTMP("BEHORXED",LP))
IF 'LP!(LP>EDT)
QUIT
Begin DoDot:1
+5 KILL ^XTMP("BEHORXED",LP)
End DoDot:1
+6 QUIT
+7 ; Return list of available visits
VSTLST(DATA,DFN,SDT,CAT) ;EP
+1 NEW EDT,IN,VST,IDT,IDT2,VIEN,NODE0,CNT,LOCNAM,LOCIEN,VDATE,VSTR,STS
+2 IF '$GET(SDT)
SET SDT=DT
+3 SET EDT=SDT+.9
+4 ;Default to Ambulatory visits
SET CAT=$GET(CAT,"A")
+5 SET DATA=$$TMPGBL^CIAVMRPC
+6 SET IDT2=9999999-(SDT\1)+.9
SET IDT=9999999-(EDT\1)
+7 SET CNT=0
+8 FOR
IF 'IDT!(IDT>IDT2)
QUIT
Begin DoDot:1
+9 SET VIEN=0
FOR
SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,IDT,VIEN))
IF 'VIEN
QUIT
Begin DoDot:2
+10 NEW PRV
+11 SET NODE0=^AUPNVSIT(VIEN,0)
+12 ; Ignore visits that are logically deleted
IF $PIECE(NODE0,U,11)
QUIT
+13 ; Compare Service Category
IF $PIECE(NODE0,U,7)'=CAT
QUIT
+14 ; Ignore logically deleted visits
IF $$ISLOCKED^BEHOENCX(VIEN)
QUIT
+15 SET VDATE=+NODE0
SET LOCIEN=$PIECE(NODE0,U,22)
SET LOCNAM=$$GET1^DIQ(44,LOCIEN,.01)
+16 SET VSTR=LOCIEN_";"_VDATE_";"_CAT_";"_VIEN
+17 SET STS=$$SET^CIAU(CAT,$PIECE($GET(^DD(9000010,.07,0)),U,3))
+18 DO GETPRV2^BEHOENCX(.PRV,VIEN,1)
+19 SET PRV=$PIECE($GET(PRV(+$ORDER(PRV(0)))),U,1,2)
+20 SET CNT=CNT+1
SET @DATA@(-VDATE,CNT)=VSTR_U_LOCNAM_U_VDATE_U_STS_U_U_PRV
End DoDot:2
End DoDot:1
SET IDT=$ORDER(^AUPNVSIT("AA",DFN,IDT))
+21 QUIT
+22 ; Post-init logic
POST ;EP-
+1 NEW OPT
+2 FOR OPT="BEHORXED DEFAULT POV","BEHORXED POV LIST","BEHORXED POV NARR TEXT"
DO OUT^XPDMENU(OPT,"Not currently used.")
DO UPDPAR("SYS",OPT)
+3 QUIT
UPDPAR(ENT,PARAM,VAL) ;EP-
+1 NEW IEN
+2 SET IEN=$ORDER(^XTV(8989.51,"B",PARAM,0))
+3 IF 'IEN
QUIT
+4 SET $PIECE(^XTV(8989.51,IEN,0),U,6)=0
+5 IF $GET(VAL)'=""
DO EN^XPAR(ENT,PARAM,,VAL)
+6 SET $PIECE(^XTV(8989.51,IEN,0),U,6)=1
+7 QUIT
