BJPNPUTL ;GDIT/HS/BEE-Prenatal Care Module Utility Calls ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**1,2,6,7,8**;Feb 24, 2015;Build 25
;
Q
;
DPOV(DATA,POVIEN,PRBIEN) ;EP - BJPN DELETE POV
;
;This RPC removes the V POV entry for the SNOMED problem and the PROBLEM 1401 entry
;
;Input:
; POVIEN - The pointer(s) to the V POV entry or entries - POV_IEN - $C(29) delimiter
; PRBIEN - The pointer to the IPL - PRBIEN
;
NEW UID,II,RET,RESULT,PIEN,PPIECE
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(POVIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VPOVIEN"_$C(30) G XDPOV
I $G(PRBIEN)="" S II=II+1,@DATA@(II)="-1^MISSING PRBIEN"_$C(30) G XDPOV
;
;Make the API call for each IEN
F PPIECE=1:1:$L(POVIEN,$C(29)) S PIEN=$P(POVIEN,$C(29),PPIECE) I PIEN]"" D I +$P(RET,U)<0 Q
. D DEL^BGOVPOV(.RET,PIEN,PRBIEN)
;
;Set up return string
I +$P(RET,U)<0 S RESULT="-1^"_$P(RET,U,2)
E S RESULT="1^"
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
XDPOV S II=II+1,@DATA@(II)=$C(31)
Q
;
PRV(DATA,VIEN,PRVIEN,PRMSEC) ;EP - BJPN SET PROVIDER
;
;This RPC sets a V PROVIDER entry for the visit
;and also possibly changes the primary provider
;
;Input:
; VIEN - Visit Pointer
; PRVIEN - Provider IEN
; PRMSEC - Primary/Secondary Provider (P/S)
;
NEW UID,II,IN,DFN,RET
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
S PRMSEC=$G(PRMSEC,"")
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
; Set primary provider
; INP = Visit IEN [1] ^ Patient IEN [2] ^ Provider IEN [3] ^ Primary/Secondary (P/S) [4] ^
; Force Conversion to Primary (Y/N) [5]
;
;Input verification
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VIEN"_$C(30) G XPRV
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
I DFN="" S II=II+1,@DATA@(II)="-1^MISSING DFN"_$C(30) G XPRV
I $$GET1^DIQ(200,PRVIEN_",",.01,"I")="" S II=II+1,@DATA@(II)="-1^INVALID PROVIDER"_$C(30) G XPRV
;
;Make call to API
S IN=VIEN_U_DFN_U_PRVIEN_U_PRMSEC
D SETVPRV^BGOVPRV(.RET,IN)
;
;Override primary if necessary
I +RET<0,PRMSEC="P" D
. S IN=IN_U_1
. D SETVPRV^BGOVPRV(.RET,IN)
;
I +RET<0 S II=II+1,@DATA@(II)="-1^PRV SAVE UNSUCCESSFUL"_$C(30) G XPRV
S II=II+1,@DATA@(II)="1^"_$C(30)
;
XPRV S II=II+1,@DATA@(II)=$C(31)
Q
;
CLOSE(DATA,VIEN) ;EP - BJPN CLOSE PIP
;
;This RPC makes each problem on the patient's PIP inactive
;
;Input:
; VIEN - Visit Pointer
;
NEW UID,II,DFN,PIPIEN,NOW,%,ERROR,TMP
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input verification
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VIEN"_$C(30) G XPRV
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
I DFN="" S II=II+1,@DATA@(II)="-1^MISSING DFN"_$C(30) G XPRV
;
;Get current date/time
D NOW^%DTC S NOW=%
;
;Call EHR API and format results into usable data
D COMP^BJPNUTIL(DFN,UID,VIEN)
S TMP=$NA(^TMP("BJPNIPL",UID)) ;Define compiled data reference
;
;Loop through each entry on the PIP
S PIPIEN="" F S PIPIEN=$O(^BJPNPL("D",DFN,PIPIEN)) Q:'PIPIEN D Q:$D(ERROR)
. ;
. NEW BJPNUP,STS,LMDT,LMBY,RSLT,PRBIEN,CSTS,ISTS,BGO,BSCO
. ;
. ;Skip deletes
. I $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" Q
. ;
. ;Status
. S STS="I"
. S CSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
. I CSTS'="I" S BJPNUP(90680.01,PIPIEN_",",.08)=STS
. ;
. ;BJPN*2.0*8;Make Scope prior pregnancy
. S BSCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
. I BSCO'="A" S BJPNUP(90680.01,PIPIEN_",",.07)="A"
. ;
. ;Last Modified Date
. S LMDT=NOW
. S BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
. ;
. ;Last Modified By
. S LMBY=DUZ
. S BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
. ;
. ;Clear Definitive EDD
. S BJPNUP(90680.01,PIPIEN_",",.09)="@"
. ;
. ;Update IPL values
. S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
. I PRBIEN]"" D I $D(ERROR) G XCLOSE
.. NEW PIP,IPLUPD
.. ;
.. ;Get the current PIP value - If set, need to clear out
.. S IPLUPD(9000011,PRBIEN_",",.03)=NOW
.. S IPLUPD(9000011,PRBIEN_",",.14)=DUZ
.. S PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I")
.. I PIP D
... NEW DA,IENS,DIC,DLAYGO,X,Y
... S IPLUPD(9000011,PRBIEN_",",.19)="@" ;Clear the PIP value
... ;
... ;Add the User/PIP value history entry
... ;
... S DIC="^BJPNPL("_PIPIEN_",5,"
... S DA(1)=PIPIEN
... S DLAYGO="90680.015",DIC("P")=$P(^DD(90680.01,5,0),U,2),DIC(0)="LOX"
... S X=NOW
... K DO,DD D FILE^DICN
... I +Y=-1 S ERROR="Could not add PIP column history" Q
... S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
... S BJPNUP(90680.015,IENS,".02")="0"
... S BJPNUP(90680.015,IENS,".03")=DUZ
.. I '$D(ERROR) D FILE^DIE("","IPLUPD","ERROR")
. I $D(ERROR) S II=II+1,@DATA@(II)="-1^^PIP CLOSE IPL UPDATE FAILED - PIPIEN:"_PIPIEN_$C(30)
. ;
. ;Update PIP entry
. I $D(BJPNUP) D FILE^DIE("","BJPNUP","ERROR")
. I $D(ERROR) S II=II+1,@DATA@(II)="-1^^PIP CLOSE FAILED - PIPIEN:"_PIPIEN_$C(30)
. ;
. ;For IPL Episodic problems, inactivate care plans/goals
. Q:PRBIEN=""
. I $$GET1^DIQ(9000011,PRBIEN_",",.12,"I")'="E" Q
. ;
. ;Loop through Care Plans
. S BGO="" F S BGO=$O(@TMP@("C",PRBIEN,BGO)) Q:BGO="" D
.. ;
.. NEW APIRES,IEN,RET
.. ;
.. S APIRES=$G(@TMP@("C",PRBIEN,BGO,0)) Q:APIRES=""
.. ;
.. ;Skip Inactive Care Plans
.. I $P(APIRES,U,6)'="A" Q
.. ;
.. ;Get the pointer to 9000092
.. S IEN=$P(APIRES,U,2) Q:IEN=""
.. D UPSTAT^BGOCPLAN(.RET,IEN,PRBIEN,"I","Closed PIP - Inactivated because IPL status is Episodic")
.. I $P($G(RET),U)="-1" S ERROR=1,II=II+1,@DATA@(II)="-1^^Could not make care plan inactive"_$C(30)
. I $D(ERROR) Q
. ;
. ;Loop through Care Plans
. S BGO="" F S BGO=$O(@TMP@("G",PRBIEN,BGO)) Q:BGO="" D
.. ;
.. NEW APIRES,IEN,RET
.. ;
.. S APIRES=$G(@TMP@("G",PRBIEN,BGO,0)) Q:APIRES=""
.. ;
.. ;Skip Inactive Care Plans
.. I $P(APIRES,U,6)'="A" Q
.. ;
.. ;Get the pointer to 9000092
.. S IEN=$P(APIRES,U,2) Q:IEN=""
.. D UPSTAT^BGOCPLAN(.RET,IEN,PRBIEN,"I","Closed PIP - Inactivated because IPL status is Episodic")
.. I $P($G(RET),U)="-1" S II=II+1,@DATA@(II)="-1^^Could not make goal inactive"_$C(30)
. I $D(ERROR) Q
;
;Record success
I '$D(ERROR) S II=II+1,@DATA@(II)="1^"_$C(30)
;
XCLOSE S II=II+1,@DATA@(II)=$C(31)
Q
;
OPEN(DATA,VIEN) ;EP - BJPN OPEN PIP
;
;This RPC makes each 'All Pregnancies' problems on the patient's PIP active
;
;Input:
; VIEN - Visit Pointer
;
NEW UID,II,DFN,PIPIEN,NOW,%,ERROR,PIPCNT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input verification
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VIEN"_$C(30) G XPRV
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
I DFN="" S II=II+1,@DATA@(II)="-1^MISSING DFN"_$C(30) G XPRV
;
;Get current date/time
D NOW^%DTC S NOW=%
;
;Loop through each entry on the PIP
S PIPCNT=0,PIPIEN="" F S PIPIEN=$O(^BJPNPL("D",DFN,PIPIEN)) Q:'PIPIEN D Q:$D(ERROR)
. ;
. NEW BJPNUP,STS,LMDT,LMBY,RSLT,IPLUPD,PRBIEN,DIC,DLAYGO,DA,IENS,X,Y
. ;
. ;Skip deletes
. I $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" Q
. ;
. ;Mark that we have an entry
. S PIPCNT=1
. ;
. S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
. I PRBIEN="" S II=II+1,@DATA@(II)="-1^Could not find PRBIEN in PIP entry: "_PIPIEN,ERROR=1 Q
. ;
. ;Include only 'All Pregnancies'
. I $$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")'="A" Q
. ;
. ;Status
. S STS="A"
. S BJPNUP(90680.01,PIPIEN_",",.08)=STS
. ;
. ;Last Modified Date
. S LMDT=NOW
. S BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
. ;
. ;Last Modified By
. S LMBY=DUZ
. S BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
. ;
. S IPLUPD(9000011,PRBIEN_",",.19)=1
. S IPLUPD(9000011,PRBIEN_",",.03)=LMDT
. S IPLUPD(9000011,PRBIEN_",",.14)=DUZ
. ;
. ;Add the IPL PIP flag
. S DIC="^BJPNPL("_PIPIEN_",5,"
. S DA(1)=PIPIEN
. S DLAYGO="90680.015",DIC("P")=$P(^DD(90680.01,5,0),U,2),DIC(0)="LOX"
. S X=NOW
. K DO,DD D FILE^DICN
. I +Y=-1 S II=II+1,@DATA@(II)="-1^Could not add PIP column history"_$C(30),ERROR=1 Q
. ;
. ;Add the User/PIP value
. S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
. S BJPNUP(90680.015,IENS,".02")=1
. S BJPNUP(90680.015,IENS,".03")=DUZ
. ;
. ;Update entry
. I $D(BJPNUP) D FILE^DIE("","BJPNUP","ERROR")
. I $D(ERROR) S II=II+1,@DATA@(II)="-1^PIP OPEN FAILED - PIPIEN:"_PIPIEN_$C(30),ERROR=1 Q
. ;
. D FILE^DIE("","IPLUPD","ERROR")
. I $D(ERROR) S II=II+1,@DATA@(II)="-1^PIP OPEN FAILED - PRBIEN:"_PRBIEN_$C(30),ERROR=1 Q
;
;Record success
I '$D(ERROR) S II=II+1,@DATA@(II)="1^"_$C(30)
;
;Broadcast update
I $G(PIPCNT)=1 D
. ;BJPN*2.0*7;Removed PPL
. ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
. D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
XOPEN S II=II+1,@DATA@(II)=$C(31)
Q
;
DEDD(DATA,VIEN) ;EP - BJPN SET DEDD
;
;This RPC updates the definitive EDD for each problem
;
;Input:
; VIEN - Visit Pointer
;
NEW UID,II,DFN,PIPIEN,NOW,%,ERROR,DEDD
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input verification
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VIEN"_$C(30) G XPRV
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
I DFN="" S II=II+1,@DATA@(II)="-1^MISSING DFN"_$C(30) G XPRV
;
;Get current date/time
D NOW^%DTC S NOW=%
;
;Pull DEDD
S DEDD=$$GET1^DIQ(9000017,DFN_",",1311,"I") S:DEDD="" DEDD="@"
;
;Loop through each entry on the PIP
S PIPIEN="" F S PIPIEN=$O(^BJPNPL("D",DFN,PIPIEN)) Q:'PIPIEN D Q:$D(ERROR)
. ;
. NEW BJPNUP,STS,LMDT,LMBY,RSLT
. ;
. ;Skip deletes
. I $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" Q
. ;
. ;DEDD
. S BJPNUP(90680.01,PIPIEN_",",.09)=DEDD
. ;
. ;Last Modified Date
. S LMDT=NOW
. S BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
. ;
. ;Last Modified By
. S LMBY=DUZ
. S BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
. ;
. ;Update entry
. I $D(BJPNUP) D FILE^DIE("","BJPNUP","ERROR")
. I $D(ERROR) S II=II+1,@DATA@(II)="-1^^UPDATE DEDD FAILED - PIPIEN:"_PIPIEN_$C(30)
;
;Record success
I '$D(ERROR) S II=II+1,@DATA@(II)="1^"_$C(30)
;
XDEDD S II=II+1,@DATA@(II)=$C(31)
Q
;
PPRV(DATA,VIEN) ;EP - BJPN GET PRIMARY PROVIDER
;
;This RPC returns the primary provider for a visit
;
;Input:
; VIEN - Visit Pointer
;
NEW UID,II,IN,PRV,XPRV
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="I00010HIDE_PRV^T00035PROVIDER"_$C(30)
;
;Input verification
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VIEN"_$C(30) G XPRV
;
;PRV fields
S (PRV,XPRV)=""
S PRV=$$PPRV^BJPNPKL(VIEN)
S:PRV="" PRV=DUZ
S XPRV=$$GET1^DIQ(200,PRV_",",.01,"E")
;
S II=II+1,@DATA@(II)=PRV_U_XPRV_$C(30)
;
XPPRV S II=II+1,@DATA@(II)=$C(31)
Q
;
PTED(N) ;Convert Education Topic to EHR viewable string
;
I $G(N)="" Q ""
;
NEW VEDIEN,TPIEN,TOPIC
;
;Pull the V PATIENT ED IEN
S VEDIEN=$P(N,U,6) Q:VEDIEN="" N
;
;Get the topic IEN
S TPIEN=$$GET1^DIQ(9000010.16,VEDIEN_",",".01","I") I TPIEN="" Q N
;
;If no SNOMED return what is there
I $$GET1^DIQ(9999999.09,TPIEN_",",.12,"I")="" Q N
;
;Get the unconverted topic
S TOPIC=$$GET1^DIQ(9999999.09,TPIEN_",",".01","I") I TOPIC="" Q N
;
;Strip off the SNOMED
S TOPIC=$P(TOPIC,"-",2) I TOPIC="" Q N
;
;See if topic can be converted
S TOPIC=$$CNVTPC(TOPIC)
S $P(N,U,2)=TOPIC
Q N
;
CNVTPC(T) ;Convert topic for EHR display
I T="DISEASE PROCESS" S T="Had Disease Process education"
I T="NUTRITION" S T="Had Nutrition education"
I T="LIFESTYLE ADAPTATION" S T="Had Lifestyle Adaptation education"
I T="PREVENTION" S T="Had Prevention education"
I T="MEDICATIONS" S T="Had Medication education"
I T="EXERCISE" S T="Had Exercise education"
Q T
;
GETABN(DATA,CONCID) ;EP - BJPN GET ABNORMAL
;
;This RPC determines whether to prompt for abnormal/normal findings for a concept
;
;Input:
; CONCID - The Concept ID
;
;Output:
; 1 - Prompt for abnormal/normal
; 0 - Do not prompt for abnormal/normal
;
NEW UID,II,RESULT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUTL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00001PROMPT_ABNORMAL"_$C(30)
;
;Input validation
I $G(CONCID)="" S II=II+1,@DATA@(II)="-1^MISSING VPOVIEN"_$C(30) G XGETABN
;
S RESULT=$P($$CONC^BSTSAPI(CONCID),U,7)
;
;Set up return string
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
XGETABN S II=II+1,@DATA@(II)=$C(31)
Q
;
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
BJPNPUTL ;GDIT/HS/BEE-Prenatal Care Module Utility Calls ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**1,2,6,7,8**;Feb 24, 2015;Build 25
+2 ;
+3 QUIT
+4 ;
DPOV(DATA,POVIEN,PRBIEN) ;EP - BJPN DELETE POV
+1 ;
+2 ;This RPC removes the V POV entry for the SNOMED problem and the PROBLEM 1401 entry
+3 ;
+4 ;Input:
+5 ; POVIEN - The pointer(s) to the V POV entry or entries - POV_IEN - $C(29) delimiter
+6 ; PRBIEN - The pointer to the IPL - PRBIEN
+7 ;
+8 NEW UID,II,RET,RESULT,PIEN,PPIECE
+9 ;
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BJPNPUTL",UID))
+12 KILL @DATA
+13 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+14 ;
+15 SET II=0
+16 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER"
+17 ;
+18 ;Define Header
+19 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+20 ;
+21 ;Input validation
+22 IF $GET(POVIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VPOVIEN"_$CHAR(30)
GOTO XDPOV
+23 IF $GET(PRBIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING PRBIEN"_$CHAR(30)
GOTO XDPOV
+24 ;
+25 ;Make the API call for each IEN
+26 FOR PPIECE=1:1:$LENGTH(POVIEN,$CHAR(29))
SET PIEN=$PIECE(POVIEN,$CHAR(29),PPIECE)
IF PIEN]""
Begin DoDot:1
+27 DO DEL^BGOVPOV(.RET,PIEN,PRBIEN)
End DoDot:1
IF +$PIECE(RET,U)<0
QUIT
+28 ;
+29 ;Set up return string
+30 IF +$PIECE(RET,U)<0
SET RESULT="-1^"_$PIECE(RET,U,2)
+31 IF '$TEST
SET RESULT="1^"
+32 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+33 ;
XDPOV SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
PRV(DATA,VIEN,PRVIEN,PRMSEC) ;EP - BJPN SET PROVIDER
+1 ;
+2 ;This RPC sets a V PROVIDER entry for the visit
+3 ;and also possibly changes the primary provider
+4 ;
+5 ;Input:
+6 ; VIEN - Visit Pointer
+7 ; PRVIEN - Provider IEN
+8 ; PRMSEC - Primary/Secondary Provider (P/S)
+9 ;
+10 NEW UID,II,IN,DFN,RET
+11 ;
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+13 SET DATA=$NAME(^TMP("BJPNPUTL",UID))
+14 KILL @DATA
+15 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+16 SET PRMSEC=$GET(PRMSEC,"")
+17 ;
+18 SET II=0
+19 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER"
+20 ;
+21 ;Define Header
+22 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+23 ;
+24 ; Set primary provider
+25 ; INP = Visit IEN [1] ^ Patient IEN [2] ^ Provider IEN [3] ^ Primary/Secondary (P/S) [4] ^
+26 ; Force Conversion to Primary (Y/N) [5]
+27 ;
+28 ;Input verification
+29 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VIEN"_$CHAR(30)
GOTO XPRV
+30 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
+31 IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DFN"_$CHAR(30)
GOTO XPRV
+32 IF $$GET1^DIQ(200,PRVIEN_",",.01,"I")=""
SET II=II+1
SET @DATA@(II)="-1^INVALID PROVIDER"_$CHAR(30)
GOTO XPRV
+33 ;
+34 ;Make call to API
+35 SET IN=VIEN_U_DFN_U_PRVIEN_U_PRMSEC
+36 DO SETVPRV^BGOVPRV(.RET,IN)
+37 ;
+38 ;Override primary if necessary
+39 IF +RET<0
IF PRMSEC="P"
Begin DoDot:1
+40 SET IN=IN_U_1
+41 DO SETVPRV^BGOVPRV(.RET,IN)
End DoDot:1
+42 ;
+43 IF +RET<0
SET II=II+1
SET @DATA@(II)="-1^PRV SAVE UNSUCCESSFUL"_$CHAR(30)
GOTO XPRV
+44 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+45 ;
XPRV SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
CLOSE(DATA,VIEN) ;EP - BJPN CLOSE PIP
+1 ;
+2 ;This RPC makes each problem on the patient's PIP inactive
+3 ;
+4 ;Input:
+5 ; VIEN - Visit Pointer
+6 ;
+7 NEW UID,II,DFN,PIPIEN,NOW,%,ERROR,TMP
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPUTL",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER"
+16 ;
+17 ;Define Header
+18 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+19 ;
+20 ;Input verification
+21 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VIEN"_$CHAR(30)
GOTO XPRV
+22 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
+23 IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DFN"_$CHAR(30)
GOTO XPRV
+24 ;
+25 ;Get current date/time
+26 DO NOW^%DTC
SET NOW=%
+27 ;
+28 ;Call EHR API and format results into usable data
+29 DO COMP^BJPNUTIL(DFN,UID,VIEN)
+30 ;Define compiled data reference
SET TMP=$NAME(^TMP("BJPNIPL",UID))
+31 ;
+32 ;Loop through each entry on the PIP
+33 SET PIPIEN=""
FOR
SET PIPIEN=$ORDER(^BJPNPL("D",DFN,PIPIEN))
IF 'PIPIEN
QUIT
Begin DoDot:1
+34 ;
+35 NEW BJPNUP,STS,LMDT,LMBY,RSLT,PRBIEN,CSTS,ISTS,BGO,BSCO
+36 ;
+37 ;Skip deletes
+38 IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
QUIT
+39 ;
+40 ;Status
+41 SET STS="I"
+42 SET CSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+43 IF CSTS'="I"
SET BJPNUP(90680.01,PIPIEN_",",.08)=STS
+44 ;
+45 ;BJPN*2.0*8;Make Scope prior pregnancy
+46 SET BSCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+47 IF BSCO'="A"
SET BJPNUP(90680.01,PIPIEN_",",.07)="A"
+48 ;
+49 ;Last Modified Date
+50 SET LMDT=NOW
+51 SET BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
+52 ;
+53 ;Last Modified By
+54 SET LMBY=DUZ
+55 SET BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
+56 ;
+57 ;Clear Definitive EDD
+58 SET BJPNUP(90680.01,PIPIEN_",",.09)="@"
+59 ;
+60 ;Update IPL values
+61 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
+62 IF PRBIEN]""
Begin DoDot:2
+63 NEW PIP,IPLUPD
+64 ;
+65 ;Get the current PIP value - If set, need to clear out
+66 SET IPLUPD(9000011,PRBIEN_",",.03)=NOW
+67 SET IPLUPD(9000011,PRBIEN_",",.14)=DUZ
+68 SET PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I")
+69 IF PIP
Begin DoDot:3
+70 NEW DA,IENS,DIC,DLAYGO,X,Y
+71 ;Clear the PIP value
SET IPLUPD(9000011,PRBIEN_",",.19)="@"
+72 ;
+73 ;Add the User/PIP value history entry
+74 ;
+75 SET DIC="^BJPNPL("_PIPIEN_",5,"
+76 SET DA(1)=PIPIEN
+77 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+78 SET X=NOW
+79 KILL DO,DD
DO FILE^DICN
+80 IF +Y=-1
SET ERROR="Could not add PIP column history"
QUIT
+81 SET DA(1)=PIPIEN
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+82 SET BJPNUP(90680.015,IENS,".02")="0"
+83 SET BJPNUP(90680.015,IENS,".03")=DUZ
End DoDot:3
+84 IF '$DATA(ERROR)
DO FILE^DIE("","IPLUPD","ERROR")
End DoDot:2
IF $DATA(ERROR)
GOTO XCLOSE
+85 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^^PIP CLOSE IPL UPDATE FAILED - PIPIEN:"_PIPIEN_$CHAR(30)
+86 ;
+87 ;Update PIP entry
+88 IF $DATA(BJPNUP)
DO FILE^DIE("","BJPNUP","ERROR")
+89 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^^PIP CLOSE FAILED - PIPIEN:"_PIPIEN_$CHAR(30)
+90 ;
+91 ;For IPL Episodic problems, inactivate care plans/goals
+92 IF PRBIEN=""
QUIT
+93 IF $$GET1^DIQ(9000011,PRBIEN_",",.12,"I")'="E"
QUIT
+94 ;
+95 ;Loop through Care Plans
+96 SET BGO=""
FOR
SET BGO=$ORDER(@TMP@("C",PRBIEN,BGO))
IF BGO=""
QUIT
Begin DoDot:2
+97 ;
+98 NEW APIRES,IEN,RET
+99 ;
+100 SET APIRES=$GET(@TMP@("C",PRBIEN,BGO,0))
IF APIRES=""
QUIT
+101 ;
+102 ;Skip Inactive Care Plans
+103 IF $PIECE(APIRES,U,6)'="A"
QUIT
+104 ;
+105 ;Get the pointer to 9000092
+106 SET IEN=$PIECE(APIRES,U,2)
IF IEN=""
QUIT
+107 DO UPSTAT^BGOCPLAN(.RET,IEN,PRBIEN,"I","Closed PIP - Inactivated because IPL status is Episodic")
+108 IF $PIECE($GET(RET),U)="-1"
SET ERROR=1
SET II=II+1
SET @DATA@(II)="-1^^Could not make care plan inactive"_$CHAR(30)
End DoDot:2
+109 IF $DATA(ERROR)
QUIT
+110 ;
+111 ;Loop through Care Plans
+112 SET BGO=""
FOR
SET BGO=$ORDER(@TMP@("G",PRBIEN,BGO))
IF BGO=""
QUIT
Begin DoDot:2
+113 ;
+114 NEW APIRES,IEN,RET
+115 ;
+116 SET APIRES=$GET(@TMP@("G",PRBIEN,BGO,0))
IF APIRES=""
QUIT
+117 ;
+118 ;Skip Inactive Care Plans
+119 IF $PIECE(APIRES,U,6)'="A"
QUIT
+120 ;
+121 ;Get the pointer to 9000092
+122 SET IEN=$PIECE(APIRES,U,2)
IF IEN=""
QUIT
+123 DO UPSTAT^BGOCPLAN(.RET,IEN,PRBIEN,"I","Closed PIP - Inactivated because IPL status is Episodic")
+124 IF $PIECE($GET(RET),U)="-1"
SET II=II+1
SET @DATA@(II)="-1^^Could not make goal inactive"_$CHAR(30)
End DoDot:2
+125 IF $DATA(ERROR)
QUIT
End DoDot:1
IF $DATA(ERROR)
QUIT
+126 ;
+127 ;Record success
+128 IF '$DATA(ERROR)
SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+129 ;
XCLOSE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
OPEN(DATA,VIEN) ;EP - BJPN OPEN PIP
+1 ;
+2 ;This RPC makes each 'All Pregnancies' problems on the patient's PIP active
+3 ;
+4 ;Input:
+5 ; VIEN - Visit Pointer
+6 ;
+7 NEW UID,II,DFN,PIPIEN,NOW,%,ERROR,PIPCNT
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPUTL",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER"
+16 ;
+17 ;Define Header
+18 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+19 ;
+20 ;Input verification
+21 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VIEN"_$CHAR(30)
GOTO XPRV
+22 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
+23 IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DFN"_$CHAR(30)
GOTO XPRV
+24 ;
+25 ;Get current date/time
+26 DO NOW^%DTC
SET NOW=%
+27 ;
+28 ;Loop through each entry on the PIP
+29 SET PIPCNT=0
SET PIPIEN=""
FOR
SET PIPIEN=$ORDER(^BJPNPL("D",DFN,PIPIEN))
IF 'PIPIEN
QUIT
Begin DoDot:1
+30 ;
+31 NEW BJPNUP,STS,LMDT,LMBY,RSLT,IPLUPD,PRBIEN,DIC,DLAYGO,DA,IENS,X,Y
+32 ;
+33 ;Skip deletes
+34 IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
QUIT
+35 ;
+36 ;Mark that we have an entry
+37 SET PIPCNT=1
+38 ;
+39 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
+40 IF PRBIEN=""
SET II=II+1
SET @DATA@(II)="-1^Could not find PRBIEN in PIP entry: "_PIPIEN
SET ERROR=1
QUIT
+41 ;
+42 ;Include only 'All Pregnancies'
+43 IF $$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")'="A"
QUIT
+44 ;
+45 ;Status
+46 SET STS="A"
+47 SET BJPNUP(90680.01,PIPIEN_",",.08)=STS
+48 ;
+49 ;Last Modified Date
+50 SET LMDT=NOW
+51 SET BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
+52 ;
+53 ;Last Modified By
+54 SET LMBY=DUZ
+55 SET BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
+56 ;
+57 SET IPLUPD(9000011,PRBIEN_",",.19)=1
+58 SET IPLUPD(9000011,PRBIEN_",",.03)=LMDT
+59 SET IPLUPD(9000011,PRBIEN_",",.14)=DUZ
+60 ;
+61 ;Add the IPL PIP flag
+62 SET DIC="^BJPNPL("_PIPIEN_",5,"
+63 SET DA(1)=PIPIEN
+64 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+65 SET X=NOW
+66 KILL DO,DD
DO FILE^DICN
+67 IF +Y=-1
SET II=II+1
SET @DATA@(II)="-1^Could not add PIP column history"_$CHAR(30)
SET ERROR=1
QUIT
+68 ;
+69 ;Add the User/PIP value
+70 SET DA(1)=PIPIEN
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+71 SET BJPNUP(90680.015,IENS,".02")=1
+72 SET BJPNUP(90680.015,IENS,".03")=DUZ
+73 ;
+74 ;Update entry
+75 IF $DATA(BJPNUP)
DO FILE^DIE("","BJPNUP","ERROR")
+76 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^PIP OPEN FAILED - PIPIEN:"_PIPIEN_$CHAR(30)
SET ERROR=1
QUIT
+77 ;
+78 DO FILE^DIE("","IPLUPD","ERROR")
+79 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^PIP OPEN FAILED - PRBIEN:"_PRBIEN_$CHAR(30)
SET ERROR=1
QUIT
End DoDot:1
IF $DATA(ERROR)
QUIT
+80 ;
+81 ;Record success
+82 IF '$DATA(ERROR)
SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+83 ;
+84 ;Broadcast update
+85 IF $GET(PIPCNT)=1
Begin DoDot:1
+86 ;BJPN*2.0*7;Removed PPL
+87 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+88 DO FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
End DoDot:1
+89 ;
XOPEN SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DEDD(DATA,VIEN) ;EP - BJPN SET DEDD
+1 ;
+2 ;This RPC updates the definitive EDD for each problem
+3 ;
+4 ;Input:
+5 ; VIEN - Visit Pointer
+6 ;
+7 NEW UID,II,DFN,PIPIEN,NOW,%,ERROR,DEDD
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPUTL",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER"
+16 ;
+17 ;Define Header
+18 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+19 ;
+20 ;Input verification
+21 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VIEN"_$CHAR(30)
GOTO XPRV
+22 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
+23 IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DFN"_$CHAR(30)
GOTO XPRV
+24 ;
+25 ;Get current date/time
+26 DO NOW^%DTC
SET NOW=%
+27 ;
+28 ;Pull DEDD
+29 SET DEDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")
IF DEDD=""
SET DEDD="@"
+30 ;
+31 ;Loop through each entry on the PIP
+32 SET PIPIEN=""
FOR
SET PIPIEN=$ORDER(^BJPNPL("D",DFN,PIPIEN))
IF 'PIPIEN
QUIT
Begin DoDot:1
+33 ;
+34 NEW BJPNUP,STS,LMDT,LMBY,RSLT
+35 ;
+36 ;Skip deletes
+37 IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
QUIT
+38 ;
+39 ;DEDD
+40 SET BJPNUP(90680.01,PIPIEN_",",.09)=DEDD
+41 ;
+42 ;Last Modified Date
+43 SET LMDT=NOW
+44 SET BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
+45 ;
+46 ;Last Modified By
+47 SET LMBY=DUZ
+48 SET BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
+49 ;
+50 ;Update entry
+51 IF $DATA(BJPNUP)
DO FILE^DIE("","BJPNUP","ERROR")
+52 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^^UPDATE DEDD FAILED - PIPIEN:"_PIPIEN_$CHAR(30)
End DoDot:1
IF $DATA(ERROR)
QUIT
+53 ;
+54 ;Record success
+55 IF '$DATA(ERROR)
SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+56 ;
XDEDD SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
PPRV(DATA,VIEN) ;EP - BJPN GET PRIMARY PROVIDER
+1 ;
+2 ;This RPC returns the primary provider for a visit
+3 ;
+4 ;Input:
+5 ; VIEN - Visit Pointer
+6 ;
+7 NEW UID,II,IN,PRV,XPRV
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPUTL",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUTL D UNWIND^%ZTER"
+16 ;
+17 ;Define Header
+18 SET @DATA@(II)="I00010HIDE_PRV^T00035PROVIDER"_$CHAR(30)
+19 ;
+20 ;Input verification
+21 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VIEN"_$CHAR(30)
GOTO XPRV
+22 ;
+23 ;PRV fields
+24 SET (PRV,XPRV)=""
+25 SET PRV=$$PPRV^BJPNPKL(VIEN)
+26 IF PRV=""
SET PRV=DUZ
+27 SET XPRV=$$GET1^DIQ(200,PRV_",",.01,"E")
+28 ;
+29 SET II=II+1
SET @DATA@(II)=PRV_U_XPRV_$CHAR(30)
+30 ;
XPPRV SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
PTED(N) ;Convert Education Topic to EHR viewable string
+1 ;
+2 IF $GET(N)=""
QUIT ""
+3 ;
+4 NEW VEDIEN,TPIEN,TOPIC
+5 ;
+6 ;Pull the V PATIENT ED IEN
+7 SET VEDIEN=$PIECE(N,U,6)
IF VEDIEN=""
QUIT N
+8 ;
+9 ;Get the topic IEN
+10 SET TPIEN=$$GET1^DIQ(9000010.16,VEDIEN_",",".01","I")
IF TPIEN=""
QUIT N
+11 ;
+12 ;If no SNOMED return what is there
+13 IF $$GET1^DIQ(9999999.09,TPIEN_",",.12,"I")=""
QUIT N
+14 ;
+15 ;Get the unconverted topic
+16 SET TOPIC=$$GET1^DIQ(9999999.09,TPIEN_",",".01","I")
IF TOPIC=""
QUIT N
+17 ;
+18 ;Strip off the SNOMED
+19 SET TOPIC=$PIECE(TOPIC,"-",2)
IF TOPIC=""
QUIT N
+20 ;
+21 ;See if topic can be converted
+22 SET TOPIC=$$CNVTPC(TOPIC)
+23 SET $PIECE(N,U,2)=TOPIC
+24 QUIT N
+25 ;
CNVTPC(T) ;Convert topic for EHR display
+1 IF T="DISEASE PROCESS"
SET T="Had Disease Process education"
+2 IF T="NUTRITION"
SET T="Had Nutrition education"
+3 IF T="LIFESTYLE ADAPTATION"
SET T="Had Lifestyle Adaptation education"
+4 IF T="PREVENTION"
SET T="Had Prevention education"
+5 IF T="MEDICATIONS"
SET T="Had Medication education"
+6 IF T="EXERCISE"
SET T="Had Exercise education"
+7 QUIT T
+8 ;
GETABN(DATA,CONCID) ;EP - BJPN GET ABNORMAL
+1 ;
+2 ;This RPC determines whether to prompt for abnormal/normal findings for a concept
+3 ;
+4 ;Input:
+5 ; CONCID - The Concept ID
+6 ;
+7 ;Output:
+8 ; 1 - Prompt for abnormal/normal
+9 ; 0 - Do not prompt for abnormal/normal
+10 ;
+11 NEW UID,II,RESULT
+12 ;
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 SET DATA=$NAME(^TMP("BJPNPUTL",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^BJPNPUTL D UNWIND^%ZTER"
+20 ;
+21 ;Define Header
+22 SET @DATA@(II)="T00001PROMPT_ABNORMAL"_$CHAR(30)
+23 ;
+24 ;Input validation
+25 IF $GET(CONCID)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VPOVIEN"_$CHAR(30)
GOTO XGETABN
+26 ;
+27 SET RESULT=$PIECE($$CONC^BSTSAPI(CONCID),U,7)
+28 ;
+29 ;Set up return string
+30 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+31 ;
XGETABN SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+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
