BJPNSPOV ;GDIT/HS/BEE-Prenatal Care Module POV Handling ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**4,6,7,9**;Feb 24, 2015;Build 12
;
Q
;
POV(DATA,INP,QUAL,INJ) ;EP - BJPN SET POV
;
;Set the problem as the POV for the visit
;
;Input parameters
; INP = VPOV IEN [1] 28 Visit IEN [2] 28 Problem IEN [3] 28 Patient IEN [4] 28 Prov Text [5] 28 Descriptive CT [6] 28
; SNOMED CT [7] 28 ICD code [8] 28 Primary/Secondary [9] 28 Provider IEN [10] 28 asthma control [11] 28 Abnormal Findings [12]
; 28 Laterality Attribute|Qualifier [13] 28 Fracture SNOMED
; QUAL = Q[1] 28 TYPE [2] 28 IEN (If edit) [3] 28 SNOMED [4] 28 BY [5] 28 WHEN [6] 28 DEL [7]
; INJ = Cause DX[1] 28 Injury Code [2] 28 Injury Place [3] 28 First/Revisit [4] 28 Injury Dt [5] 28 Onset Date [6]
;
;Return value: SUCCESS^VPOV IEN^ERROR MESSAGE
;1^VPOV IEN - Success
;-1^^Error Message
;
NEW UID,II,RET,RESULT,PPRV,VIEN,DXCAUSE,ZTQUEUED,POVIEN,ICD,AF
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNSPOV",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
;Set ZTQUEUED - which fixes an error in the save with data getting displayed to the screen
S ZTQUEUED=""
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNSPOV D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00010POV_IEN^T00150ERROR_MESSAGE"_$C(30)
;
;Translate the incoming data delimiters
S INP=$TR($G(INP),$C(28),"^")
S QUAL=$TR($G(QUAL),$C(28),"^")
S INJ=$TR($G(INJ),$C(28),"^")
;
;Only allow one ICD
S ICD=$P(INP,U,8) I ICD["|" S $P(INP,U,8)=$P(ICD,"|")
;
;Make sure provider IEN is populated
S VIEN=$P(INP,U,2)
;Default saved by to DUZ
;S PPRV=$P(INP,U,10)
S PPRV=DUZ
I PPRV="" S PPRV=$$PPRV^BJPNPKL(VIEN)
S $P(INP,U,10)=PPRV
;
;Populate Q By/Date
I $G(QUAL)]"" D
. NEW %
. I $P(QUAL,U,5)]"" Q
. S $P(QUAL,U,5)=DUZ
. D NOW^%DTC
. S $P(QUAL,U,6)=%
;
;BJPN*2.0*6;Handle abnormal findings
;Convert AF from text to SNOMED
S AF=$P(INP,U,12) S:AF="" AF="@"
I AF]"",AF'="@" S AF=$O(^BSTS(9002318.6,"D","AF",AF,""))
S $P(INP,U,12)=""
;
;Convert Dx Cause to uppercase
S $P(INJ,U)=$$UPPER($P(INJ,U))
;
;Convert Injury Date
S $P(INJ,U,5)=$$DATE^BJPNPRUT($P(INJ,U,5))
;
;Convert Onset Date
S $P(INJ,U,6)=$$DATE^BJPNPRUT($P(INJ,U,6))
;
;Make the EHR POV call
;
;Process adds
S RESULT=""
I $TR($P(INP,U),$C(29))="" D
. D SET^BGOVPOV(.RET,INP,QUAL,INJ,AF)
. ;
. ;Format output
. I +RET>0 S RESULT="1^"_+RET
. E S RESULT="-1^^"_$P(RET,U,2)
;
;Process edits
I $TR($P(INP,U),$C(29))]"" D
. NEW LIST,PC,PVIEN
. S PVIEN=$P(INP,U) ;Clear PVIENs
. S $P(INP,U,8)="" ;Clear ICD
. S LIST=""
. F PC=1:1:$L(PVIEN,$C(29)) I $P(PVIEN,$C(29),PC)]"" S LIST(PC-1)=$P(PVIEN,$C(29),PC)
. S $P(INP,U)=""
. D EDIT^BGOVPOV3(.RET,INP,.LIST,QUAL,INJ,AF)
. ;
. ;Format output
. I +$P(RET,";",2)>0 S RESULT="1^"_+$P(RET,";",2)
. E S RESULT="-1^^"_$P(RET,U,2)
;
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
XPOV S II=II+1,@DATA@(II)=$C(31)
Q
;
;
FRACT(DATA,CONCID) ;EP - BJPN GET FRACTURE
;
;This RPC determines whether to prompt for fractures by returning the valid
;fracture choices
;
;Input:
; CONCID - The Concept ID
;
;Output:
; DISPLAY^SNOMED
;
NEW UID,II,RESULT,PC
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNSPOV",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNSPOV D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00050DISPLAY_NAME^T00020SNOMED"_$C(30)
;
;Input validation
I $G(CONCID)="" S II=II+1,@DATA@(II)="-1^MISSING CONCEPT ID"_$C(30) G XFRACT
;
;Retrieve the fracture information
S RESULT=$P($$CONC^BSTSAPI(CONCID),U,11)
I RESULT]"" F PC=1:1:$L(RESULT,";") D
. NEW HEAL
. S HEAL=$P(RESULT,";",PC) Q:$TR(HEAL,"|")=""
. S II=II+1,@DATA@(II)=$P(HEAL,"|")_"^"_$P(HEAL,"|",2)_$C(30)
;
XFRACT S II=II+1,@DATA@(II)=$C(31)
Q
;
UPPER(X) ;Convert to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S II=II+1,@DATA@(II)=$C(31)
Q
BJPNSPOV ;GDIT/HS/BEE-Prenatal Care Module POV Handling ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**4,6,7,9**;Feb 24, 2015;Build 12
+2 ;
+3 QUIT
+4 ;
POV(DATA,INP,QUAL,INJ) ;EP - BJPN SET POV
+1 ;
+2 ;Set the problem as the POV for the visit
+3 ;
+4 ;Input parameters
+5 ; INP = VPOV IEN [1] 28 Visit IEN [2] 28 Problem IEN [3] 28 Patient IEN [4] 28 Prov Text [5] 28 Descriptive CT [6] 28
+6 ; SNOMED CT [7] 28 ICD code [8] 28 Primary/Secondary [9] 28 Provider IEN [10] 28 asthma control [11] 28 Abnormal Findings [12]
+7 ; 28 Laterality Attribute|Qualifier [13] 28 Fracture SNOMED
+8 ; QUAL = Q[1] 28 TYPE [2] 28 IEN (If edit) [3] 28 SNOMED [4] 28 BY [5] 28 WHEN [6] 28 DEL [7]
+9 ; INJ = Cause DX[1] 28 Injury Code [2] 28 Injury Place [3] 28 First/Revisit [4] 28 Injury Dt [5] 28 Onset Date [6]
+10 ;
+11 ;Return value: SUCCESS^VPOV IEN^ERROR MESSAGE
+12 ;1^VPOV IEN - Success
+13 ;-1^^Error Message
+14 ;
+15 NEW UID,II,RET,RESULT,PPRV,VIEN,DXCAUSE,ZTQUEUED,POVIEN,ICD,AF
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BJPNSPOV",UID))
+18 KILL @DATA
+19 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+20 ;
+21 ;Set ZTQUEUED - which fixes an error in the save with data getting displayed to the screen
+22 SET ZTQUEUED=""
+23 ;
+24 SET II=0
+25 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNSPOV D UNWIND^%ZTER"
+26 ;
+27 ;Define Header
+28 SET @DATA@(II)="T00005RESULT^T00010POV_IEN^T00150ERROR_MESSAGE"_$CHAR(30)
+29 ;
+30 ;Translate the incoming data delimiters
+31 SET INP=$TRANSLATE($GET(INP),$CHAR(28),"^")
+32 SET QUAL=$TRANSLATE($GET(QUAL),$CHAR(28),"^")
+33 SET INJ=$TRANSLATE($GET(INJ),$CHAR(28),"^")
+34 ;
+35 ;Only allow one ICD
+36 SET ICD=$PIECE(INP,U,8)
IF ICD["|"
SET $PIECE(INP,U,8)=$PIECE(ICD,"|")
+37 ;
+38 ;Make sure provider IEN is populated
+39 SET VIEN=$PIECE(INP,U,2)
+40 ;Default saved by to DUZ
+41 ;S PPRV=$P(INP,U,10)
+42 SET PPRV=DUZ
+43 IF PPRV=""
SET PPRV=$$PPRV^BJPNPKL(VIEN)
+44 SET $PIECE(INP,U,10)=PPRV
+45 ;
+46 ;Populate Q By/Date
+47 IF $GET(QUAL)]""
Begin DoDot:1
+48 NEW %
+49 IF $PIECE(QUAL,U,5)]""
QUIT
+50 SET $PIECE(QUAL,U,5)=DUZ
+51 DO NOW^%DTC
+52 SET $PIECE(QUAL,U,6)=%
End DoDot:1
+53 ;
+54 ;BJPN*2.0*6;Handle abnormal findings
+55 ;Convert AF from text to SNOMED
+56 SET AF=$PIECE(INP,U,12)
IF AF=""
SET AF="@"
+57 IF AF]""
IF AF'="@"
SET AF=$ORDER(^BSTS(9002318.6,"D","AF",AF,""))
+58 SET $PIECE(INP,U,12)=""
+59 ;
+60 ;Convert Dx Cause to uppercase
+61 SET $PIECE(INJ,U)=$$UPPER($PIECE(INJ,U))
+62 ;
+63 ;Convert Injury Date
+64 SET $PIECE(INJ,U,5)=$$DATE^BJPNPRUT($PIECE(INJ,U,5))
+65 ;
+66 ;Convert Onset Date
+67 SET $PIECE(INJ,U,6)=$$DATE^BJPNPRUT($PIECE(INJ,U,6))
+68 ;
+69 ;Make the EHR POV call
+70 ;
+71 ;Process adds
+72 SET RESULT=""
+73 IF $TRANSLATE($PIECE(INP,U),$CHAR(29))=""
Begin DoDot:1
+74 DO SET^BGOVPOV(.RET,INP,QUAL,INJ,AF)
+75 ;
+76 ;Format output
+77 IF +RET>0
SET RESULT="1^"_+RET
+78 IF '$TEST
SET RESULT="-1^^"_$PIECE(RET,U,2)
End DoDot:1
+79 ;
+80 ;Process edits
+81 IF $TRANSLATE($PIECE(INP,U),$CHAR(29))]""
Begin DoDot:1
+82 NEW LIST,PC,PVIEN
+83 ;Clear PVIENs
SET PVIEN=$PIECE(INP,U)
+84 ;Clear ICD
SET $PIECE(INP,U,8)=""
+85 SET LIST=""
+86 FOR PC=1:1:$LENGTH(PVIEN,$CHAR(29))
IF $PIECE(PVIEN,$CHAR(29),PC)]""
SET LIST(PC-1)=$PIECE(PVIEN,$CHAR(29),PC)
+87 SET $PIECE(INP,U)=""
+88 DO EDIT^BGOVPOV3(.RET,INP,.LIST,QUAL,INJ,AF)
+89 ;
+90 ;Format output
+91 IF +$PIECE(RET,";",2)>0
SET RESULT="1^"_+$PIECE(RET,";",2)
+92 IF '$TEST
SET RESULT="-1^^"_$PIECE(RET,U,2)
End DoDot:1
+93 ;
+94 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+95 ;
XPOV SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
+3 ;
FRACT(DATA,CONCID) ;EP - BJPN GET FRACTURE
+1 ;
+2 ;This RPC determines whether to prompt for fractures by returning the valid
+3 ;fracture choices
+4 ;
+5 ;Input:
+6 ; CONCID - The Concept ID
+7 ;
+8 ;Output:
+9 ; DISPLAY^SNOMED
+10 ;
+11 NEW UID,II,RESULT,PC
+12 ;
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 SET DATA=$NAME(^TMP("BJPNSPOV",UID))
+15 KILL @DATA
+16 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+17 ;
+18 SET II=0
+19 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNSPOV D UNWIND^%ZTER"
+20 ;
+21 ;Define Header
+22 SET @DATA@(II)="T00050DISPLAY_NAME^T00020SNOMED"_$CHAR(30)
+23 ;
+24 ;Input validation
+25 IF $GET(CONCID)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING CONCEPT ID"_$CHAR(30)
GOTO XFRACT
+26 ;
+27 ;Retrieve the fracture information
+28 SET RESULT=$PIECE($$CONC^BSTSAPI(CONCID),U,11)
+29 IF RESULT]""
FOR PC=1:1:$LENGTH(RESULT,";")
Begin DoDot:1
+30 NEW HEAL
+31 SET HEAL=$PIECE(RESULT,";",PC)
IF $TRANSLATE(HEAL,"|")=""
QUIT
+32 SET II=II+1
SET @DATA@(II)=$PIECE(HEAL,"|")_"^"_$PIECE(HEAL,"|",2)_$CHAR(30)
End DoDot:1
+33 ;
XFRACT SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
UPPER(X) ;Convert to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 QUIT
