BJPNSPOV.m

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