BJPNCPIP ;GDIT/HS/BEE-Prenatal Care Module Problem Handling Calls ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**7,8**;Feb 24, 2015;Build 25
;
Q
;
CDEL(DATA,DESCID,DFN) ;EP - BJPN CAN DELETE
;
;Determine whether problem can be deleted from the PIP/IPL
;
NEW UID,II,CONCID,PRBIEN,PIPIEN,CDEL,PSTATUS,TMP
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNCPIP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="T00001CAN_DELETE^T00001PIP_STATUS"_$C(30)
;
;Input validation
I $G(DESCID)="" S II=II+1,@DATA@(II)="-1^MISSING DESCID"_$C(30) G XCDEL
I $G(DFN)="" S II=II+1,@DATA@(II)="-1^MISSING DFN"_$C(30) G XCDEL
;
;Get the Concept ID
S CONCID=$P($$DESC^BSTSAPI(DESCID_"^^1"),U) I CONCID="" S II=II+1,@DATA@(II)="-1^COULD NOT FIND CONCEPT ID"_$C(30) G XDEL
;
;Locate the PIP entry
S (PIPIEN,PRBIEN,PSTATUS)=""
F S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN="" D Q:PIPIEN
. NEW BPIEN,IPLCNC,DEL
. ;
. ;Skip deletes
. S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" Q ;IPL Delete
. ;
. ;Get the Concept Id of the IPL entry - Look for a match
. S IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") Q:IPLCNC=""
. I IPLCNC'=CONCID Q
. ;
. ;Verify the PIPIEN is correct
. S BPIEN="" F S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN="" D Q:PIPIEN
.. NEW DEL
.. ;
.. ;Skip deletes
.. S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") I DEL]"" Q
.. ;
.. ;Set the PIPIEN
.. S PIPIEN=BPIEN
.. S PSTATUS=$$GET1^DIQ(90680.01,BPIEN_",",.08,"I")
;
;Quit if no PIP entry found
I ($G(PIPIEN)="")!($G(PRBIEN)="") S II=II+1,@DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$C(30) G XCDEL
;
;Pull the IPL information - Determine if problem can be deleted
D COMP^BJPNUTIL(DFN,UID,"",PRBIEN)
S TMP=$NA(^TMP("BJPNIPL",UID)) ;Define compiled data reference
;
;Reset Can Delete flag
D
. NEW GGO,CGO,TGO,VGO,CPGSTS
. ;Reset Can Delete flag
. S CDEL="Y"
. ;
. ;Get Goal notes
. S GGO="" F S GGO=$O(@TMP@("G",PRBIEN,GGO)) Q:GGO="" D Q:CDEL=""
.. ;
.. ;Look for inactive or active goals
.. S CPGSTS=$P($G(@TMP@("G",PRBIEN,GGO,0)),U,6)
.. I (CPGSTS="I")!(CPGSTS="A") S CDEL="" Q
. ;
. ;Get Care Plans
. S CGO="" F S CGO=$O(@TMP@("C",PRBIEN,CGO)) Q:CGO="" D Q:CDEL=""
.. ;
.. ;Look for inactive or active Care Plans
.. S CPGSTS=$P($G(@TMP@("C",PRBIEN,CGO,0)),U,6)
.. I (CPGSTS="I")!(CPGSTS="A") S CDEL="" Q
. ;
. ;Look for Treatment/Regimen
. S TGO=$O(@TMP@("T",PRBIEN,"")) I TGO]"" S CDEL=""
. ;
. ;Look for V Visit Instruction
. S VGO=$O(@TMP@("I",PRBIEN,"")) I VGO]"" S CDEL=""
. ;
. ;Ever a POV - needed for deleting permission
. I $O(^AUPNPROB(PRBIEN,14,"B",""))]"" S CDEL=""
. I $O(^AUPNPROB(PRBIEN,15,"B",""))]"" S CDEL=""
;
;Quit if not allowed to delete
S II=II+1,@DATA@(II)=CDEL_U_PSTATUS_$C(30)
;
XCDEL S II=II+1,@DATA@(II)=$C(31)
Q
;
CPSTS(DATA,DESCID,DFN) ;EP - BJPN PICK LIST TOGGLE STATUS
;
;Toggle a problem status from the pick list
;
NEW UID,II,CONCID,PRBIEN,PIPIEN,STS,%,NOW,NSTS,BJPNUPD,IPLUPD,DIC,DA,DLAYGO,X,Y,IENS,PIP,ERROR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNCPIP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(DESCID)="" S II=II+1,@DATA@(II)="-1^MISSING DESCID"_$C(30) G XCPSTS
I $G(DFN)="" S II=II+1,@DATA@(II)="-1^MISSING DFN"_$C(30) G XCPSTS
;
;Get the Concept ID
S CONCID=$P($$DESC^BSTSAPI(DESCID_"^^1"),U) I CONCID="" S II=II+1,@DATA@(II)="-1^COULD NOT FIND CONCEPT ID"_$C(30) G XCPSTS
;
;Locate the PIP entry
S (PIPIEN,PRBIEN)=""
F S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN="" D Q:PIPIEN
. NEW BPIEN,IPLCNC,DEL
. ;
. ;Skip deletes
. S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" Q ;IPL Delete
. ;
. ;Get the Concept Id of the IPL entry - Look for a match
. S IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") Q:IPLCNC=""
. I IPLCNC'=CONCID Q
. ;
. ;Verify the PIPIEN is correct
. S BPIEN="" F S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN="" D Q:PIPIEN
.. NEW DEL
.. ;
.. ;Skip deletes
.. S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") I DEL]"" Q
.. ;
.. ;Set the PIPIEN
.. S PIPIEN=BPIEN
;
;Quit if no PIP entry found
I ($G(PIPIEN)="")!($G(PRBIEN)="") S II=II+1,@DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$C(30) G XCPSTS
;
D NOW^%DTC S NOW=%
;
;Get the problem (IPL) IEN
S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I") I PRBIEN="" S II=II+1,@DATA@(II)="-1^INVALID IPL POINTER"_$C(30) G XCPSTS
;
;Get the current status
S STS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
I STS'="A",STS'="I" S STS="I" ;Default to "A" if null
;
;Define new values
I STS="A" S NSTS="I",PIP="@"
I STS="I" S NSTS="A",PIP=1
S BJPNUPD(90680.01,PIPIEN_",",.08)=NSTS
S BJPNUPD(9000011,PRBIEN_",",.19)=PIP
S IPLUPD(9000011,PRBIEN_",",.03)=NOW
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" G XCPSTS
;
;Add the User/PIP value
S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
S BJPNUPD(90680.015,IENS,".02")=$S(PIP=1:1,1:0)
S BJPNUPD(90680.015,IENS,".03")=DUZ
;
D FILE^DIE("","BJPNUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^Status PIP update change failed"_$C(30) G XCPSTS
D FILE^DIE("","IPLUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^Status IPL update change failed"_$C(30) G XCPSTS
;
;Broadcast update
;BJPN*2.0*7;Removed PPL
;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
S II=II+1,@DATA@(II)="1^"_$C(30)
;
XCPSTS S II=II+1,@DATA@(II)=$C(31)
Q
;
DEL(DATA,VIEN,PIPIEN,DCODE,DRSN,DELIPL) ;BJPN DELETE PIP PROBLEM
;
;Delete prenatal problem from PIP and IPL
;
NEW UID,II,%,NOW,PRUPD,ERROR,RSLT,DFN,PROC,DTTM,VFL,VPUPD,PRBIEN,DIC,DA,X,Y,DLAYGO
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNCPIP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VISIT IEN"_$C(30) G XDEL
I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^MISSING PIPIEN"_$C(30) G XDEL
S DELIPL=$G(DELIPL)
I $$GET1^DIQ(90680.01,PIPIEN_",",".01","I")="" S II=II+1,@DATA@(II)="-1^INVALID PIPIEN"_$C(30) G XDEL
I $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" S II=II+1,@DATA@(II)="-1^PROBLEM ALREADY DELETED"_$C(30) G XDEL
S DCODE=$G(DCODE,""),DRSN=$G(DRSN,"")
;
D NOW^%DTC S NOW=%
;
;Retrieve DFN
S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I") I DFN="" S II=II+1,@DATA@(II)="-1^INVALID VISIT"_$C(30) G XDEL
;
;Get the problem (IPL) IEN
S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I") I PRBIEN="" S II=II+1,@DATA@(II)="-1^INVALID IPL POINTER"_$C(30) G XDEL
;
;Mark as deleted - PIP
S RSLT="1"
S PRUPD(90680.01,PIPIEN_",",2.01)=DUZ
S PRUPD(90680.01,PIPIEN_",",2.02)=NOW
S PRUPD(90680.01,PIPIEN_",",2.03)=DCODE
S PRUPD(90680.01,PIPIEN_",",2.04)=DRSN
S PRUPD(9000011,PRBIEN_",",.19)="@" ;Remove from PIP column in IPL
I $D(PRUPD) D FILE^DIE("","PRUPD","ERROR")
I $D(ERROR) S RSLT="-1^PIP DELETE FAILED",II=II+1,@DATA@(II)=RSLT_$C(30) G XDEL
;
;
;Add the IPL PIP flag history
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" G XDEL
;
;Mark as deleted - IPL
S RSLT="1"
I $G(DELIPL)=1 D I RSLT'=1 G XDEL
. NEW IPLUPD
. S IPLUPD(9000011,PRBIEN_",",.12)="D"
. S IPLUPD(9000011,PRBIEN_",",2.01)=DUZ
. S IPLUPD(9000011,PRBIEN_",",2.02)=NOW
. S IPLUPD(9000011,PRBIEN_",",2.03)=DCODE
. S IPLUPD(9000011,PRBIEN_",",2.04)=DRSN
. S IPLUPD(9000011,PRBIEN_",",.03)=NOW
. S IPLUPD(9000011,PRBIEN_",",.14)=DUZ
. D FILE^DIE("","IPLUPD","ERROR")
. I $D(ERROR) S RSLT="-1^IPL DELETE FAILED",II=II+1,@DATA@(II)=RSLT_$C(30)
;
S II=II+1,@DATA@(II)="1^"_$C(30)
;
;Broadcast update
;BJPN*2.0*7;Remove PPL alert
;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
XDEL S II=II+1,@DATA@(II)=$C(31)
Q
;
STS(DATA,PIPIEN,VIEN) ;EP - BJPN TOGGLE STATUS
;
;Toggle the PIP status of a problem
;
NEW UID,II,STS,RESULT,PRBIEN,NSTS,PIP,BJPNUPD,ERROR,DFN,IPLUPD
NEW DIC,DA,DLAYGO,X,Y,IENS
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNCPIP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VISIT IEN"_$C(30) G XSTS
I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^MISSING PIPIEN"_$C(30) G XSTS
;
D NOW^%DTC S NOW=%
;
;Get the problem (IPL) IEN
S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I") I PRBIEN="" S II=II+1,@DATA@(II)="-1^INVALID IPL POINTER"_$C(30) G XSTS
S DFN=$$GET1^DIQ(9000011,PRBIEN_",",.02,"I")
;
;Get the current status
S STS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
I STS'="A",STS'="I" S STS="I" ;Default to "A" if null
;
;Define new values
I STS="A" S NSTS="I",PIP="@"
I STS="I" S NSTS="A",PIP=1
S BJPNUPD(90680.01,PIPIEN_",",.08)=NSTS
S BJPNUPD(9000011,PRBIEN_",",.19)=PIP
S IPLUPD(9000011,PRBIEN_",",.03)=NOW
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" G XSTS
;
;Add the User/PIP value
S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
S BJPNUPD(90680.015,IENS,".02")=$S(PIP=1:1,1:0)
S BJPNUPD(90680.015,IENS,".03")=DUZ
;
D FILE^DIE("","BJPNUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^Status PIP update change failed"_$C(30) G XSTS
D FILE^DIE("","IPLUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^Status IPL update change failed"_$C(30) G XSTS
;
;Broadcast update
;BJPN*2.0*7;Remove PPL alert since it has been removed
;D FIREEV^BJPNPDET("","REFRESH")
;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
S II=II+1,@DATA@(II)="1^"_$C(30)
;
XSTS S II=II+1,@DATA@(II)=$C(31)
Q
;
SCO(DATA,PIPIEN,VIEN) ;EP - BJPN TOGGLE SCOPE
;
;Toggle the PIP scope of a problem
;
NEW UID,II,SCO,RESULT,PRBIEN,NSCO,BJPNUPD,ERROR,DFN,IPLUPD
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNCPIP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VISIT IEN"_$C(30) G XSCO
I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^MISSING PIPIEN"_$C(30) G XSCO
;
D NOW^%DTC S NOW=%
;
;Get the problem (IPL) IEN
S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I") I PRBIEN="" S II=II+1,@DATA@(II)="-1^INVALID IPL POINTER"_$C(30) G XSCO
S DFN=$$GET1^DIQ(9000011,PRBIEN_",",.02,"I")
;
;Get the current scope
S SCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
I SCO'="A",SCO'="C" S SCO="A"
;
;Define new values
I SCO="A" S NSCO="C"
I SCO="C" S NSCO="A"
S BJPNUPD(90680.01,PIPIEN_",",.07)=NSCO
S IPLUPD(9000011,PRBIEN_",",.03)=NOW
S IPLUPD(9000011,PRBIEN_",",.14)=DUZ
D FILE^DIE("","BJPNUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^Scope change failed"_$C(30) G XSCO
D FILE^DIE("","IPLUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^Scope change failed"_$C(30) G XSCO
;
;Broadcast update
;D FIREEV^BJPNPDET("","REFRESH")
;BJPN*2.0*7;Remove refreshes as being handled by GUI
;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
;D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
S II=II+1,@DATA@(II)="1^"_$C(30)
;
XSCO 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
BJPNCPIP ;GDIT/HS/BEE-Prenatal Care Module Problem Handling Calls ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**7,8**;Feb 24, 2015;Build 25
+2 ;
+3 QUIT
+4 ;
CDEL(DATA,DESCID,DFN) ;EP - BJPN CAN DELETE
+1 ;
+2 ;Determine whether problem can be deleted from the PIP/IPL
+3 ;
+4 NEW UID,II,CONCID,PRBIEN,PIPIEN,CDEL,PSTATUS,TMP
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BJPNCPIP",UID))
+7 KILL @DATA
+8 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+9 ;
+10 SET II=0
+11 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER"
+12 ;
+13 SET @DATA@(II)="T00001CAN_DELETE^T00001PIP_STATUS"_$CHAR(30)
+14 ;
+15 ;Input validation
+16 IF $GET(DESCID)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DESCID"_$CHAR(30)
GOTO XCDEL
+17 IF $GET(DFN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DFN"_$CHAR(30)
GOTO XCDEL
+18 ;
+19 ;Get the Concept ID
+20 SET CONCID=$PIECE($$DESC^BSTSAPI(DESCID_"^^1"),U)
IF CONCID=""
SET II=II+1
SET @DATA@(II)="-1^COULD NOT FIND CONCEPT ID"_$CHAR(30)
GOTO XDEL
+21 ;
+22 ;Locate the PIP entry
+23 SET (PIPIEN,PRBIEN,PSTATUS)=""
+24 FOR
SET PRBIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN))
IF PRBIEN=""
QUIT
Begin DoDot:1
+25 NEW BPIEN,IPLCNC,DEL
+26 ;
+27 ;Skip deletes
+28 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
QUIT
+29 ;
+30 ;Get the Concept Id of the IPL entry - Look for a match
+31 SET IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")
IF IPLCNC=""
QUIT
+32 IF IPLCNC'=CONCID
QUIT
+33 ;
+34 ;Verify the PIPIEN is correct
+35 SET BPIEN=""
FOR
SET BPIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN,BPIEN))
IF BPIEN=""
QUIT
Begin DoDot:2
+36 NEW DEL
+37 ;
+38 ;Skip deletes
+39 SET DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I")
IF DEL]""
QUIT
+40 ;
+41 ;Set the PIPIEN
+42 SET PIPIEN=BPIEN
+43 SET PSTATUS=$$GET1^DIQ(90680.01,BPIEN_",",.08,"I")
End DoDot:2
IF PIPIEN
QUIT
End DoDot:1
IF PIPIEN
QUIT
+44 ;
+45 ;Quit if no PIP entry found
+46 IF ($GET(PIPIEN)="")!($GET(PRBIEN)="")
SET II=II+1
SET @DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$CHAR(30)
GOTO XCDEL
+47 ;
+48 ;Pull the IPL information - Determine if problem can be deleted
+49 DO COMP^BJPNUTIL(DFN,UID,"",PRBIEN)
+50 ;Define compiled data reference
SET TMP=$NAME(^TMP("BJPNIPL",UID))
+51 ;
+52 ;Reset Can Delete flag
+53 Begin DoDot:1
+54 NEW GGO,CGO,TGO,VGO,CPGSTS
+55 ;Reset Can Delete flag
+56 SET CDEL="Y"
+57 ;
+58 ;Get Goal notes
+59 SET GGO=""
FOR
SET GGO=$ORDER(@TMP@("G",PRBIEN,GGO))
IF GGO=""
QUIT
Begin DoDot:2
+60 ;
+61 ;Look for inactive or active goals
+62 SET CPGSTS=$PIECE($GET(@TMP@("G",PRBIEN,GGO,0)),U,6)
+63 IF (CPGSTS="I")!(CPGSTS="A")
SET CDEL=""
QUIT
End DoDot:2
IF CDEL=""
QUIT
+64 ;
+65 ;Get Care Plans
+66 SET CGO=""
FOR
SET CGO=$ORDER(@TMP@("C",PRBIEN,CGO))
IF CGO=""
QUIT
Begin DoDot:2
+67 ;
+68 ;Look for inactive or active Care Plans
+69 SET CPGSTS=$PIECE($GET(@TMP@("C",PRBIEN,CGO,0)),U,6)
+70 IF (CPGSTS="I")!(CPGSTS="A")
SET CDEL=""
QUIT
End DoDot:2
IF CDEL=""
QUIT
+71 ;
+72 ;Look for Treatment/Regimen
+73 SET TGO=$ORDER(@TMP@("T",PRBIEN,""))
IF TGO]""
SET CDEL=""
+74 ;
+75 ;Look for V Visit Instruction
+76 SET VGO=$ORDER(@TMP@("I",PRBIEN,""))
IF VGO]""
SET CDEL=""
+77 ;
+78 ;Ever a POV - needed for deleting permission
+79 IF $ORDER(^AUPNPROB(PRBIEN,14,"B",""))]""
SET CDEL=""
+80 IF $ORDER(^AUPNPROB(PRBIEN,15,"B",""))]""
SET CDEL=""
End DoDot:1
+81 ;
+82 ;Quit if not allowed to delete
+83 SET II=II+1
SET @DATA@(II)=CDEL_U_PSTATUS_$CHAR(30)
+84 ;
XCDEL SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
CPSTS(DATA,DESCID,DFN) ;EP - BJPN PICK LIST TOGGLE STATUS
+1 ;
+2 ;Toggle a problem status from the pick list
+3 ;
+4 NEW UID,II,CONCID,PRBIEN,PIPIEN,STS,%,NOW,NSTS,BJPNUPD,IPLUPD,DIC,DA,DLAYGO,X,Y,IENS,PIP,ERROR
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BJPNCPIP",UID))
+7 KILL @DATA
+8 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+9 ;
+10 SET II=0
+11 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER"
+12 ;
+13 ;Define Header
+14 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+15 ;
+16 ;Input validation
+17 IF $GET(DESCID)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DESCID"_$CHAR(30)
GOTO XCPSTS
+18 IF $GET(DFN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING DFN"_$CHAR(30)
GOTO XCPSTS
+19 ;
+20 ;Get the Concept ID
+21 SET CONCID=$PIECE($$DESC^BSTSAPI(DESCID_"^^1"),U)
IF CONCID=""
SET II=II+1
SET @DATA@(II)="-1^COULD NOT FIND CONCEPT ID"_$CHAR(30)
GOTO XCPSTS
+22 ;
+23 ;Locate the PIP entry
+24 SET (PIPIEN,PRBIEN)=""
+25 FOR
SET PRBIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN))
IF PRBIEN=""
QUIT
Begin DoDot:1
+26 NEW BPIEN,IPLCNC,DEL
+27 ;
+28 ;Skip deletes
+29 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
QUIT
+30 ;
+31 ;Get the Concept Id of the IPL entry - Look for a match
+32 SET IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")
IF IPLCNC=""
QUIT
+33 IF IPLCNC'=CONCID
QUIT
+34 ;
+35 ;Verify the PIPIEN is correct
+36 SET BPIEN=""
FOR
SET BPIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN,BPIEN))
IF BPIEN=""
QUIT
Begin DoDot:2
+37 NEW DEL
+38 ;
+39 ;Skip deletes
+40 SET DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I")
IF DEL]""
QUIT
+41 ;
+42 ;Set the PIPIEN
+43 SET PIPIEN=BPIEN
End DoDot:2
IF PIPIEN
QUIT
End DoDot:1
IF PIPIEN
QUIT
+44 ;
+45 ;Quit if no PIP entry found
+46 IF ($GET(PIPIEN)="")!($GET(PRBIEN)="")
SET II=II+1
SET @DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$CHAR(30)
GOTO XCPSTS
+47 ;
+48 DO NOW^%DTC
SET NOW=%
+49 ;
+50 ;Get the problem (IPL) IEN
+51 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
IF PRBIEN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID IPL POINTER"_$CHAR(30)
GOTO XCPSTS
+52 ;
+53 ;Get the current status
+54 SET STS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+55 ;Default to "A" if null
IF STS'="A"
IF STS'="I"
SET STS="I"
+56 ;
+57 ;Define new values
+58 IF STS="A"
SET NSTS="I"
SET PIP="@"
+59 IF STS="I"
SET NSTS="A"
SET PIP=1
+60 SET BJPNUPD(90680.01,PIPIEN_",",.08)=NSTS
+61 SET BJPNUPD(9000011,PRBIEN_",",.19)=PIP
+62 SET IPLUPD(9000011,PRBIEN_",",.03)=NOW
+63 SET IPLUPD(9000011,PRBIEN_",",.14)=DUZ
+64 ;
+65 ;Add the IPL PIP flag
+66 SET DIC="^BJPNPL("_PIPIEN_",5,"
+67 SET DA(1)=PIPIEN
+68 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+69 SET X=NOW
+70 KILL DO,DD
DO FILE^DICN
+71 IF +Y=-1
SET II=II+1
SET @DATA@(II)="-1^Could not add PIP column history"
GOTO XCPSTS
+72 ;
+73 ;Add the User/PIP value
+74 SET DA(1)=PIPIEN
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+75 SET BJPNUPD(90680.015,IENS,".02")=$SELECT(PIP=1:1,1:0)
+76 SET BJPNUPD(90680.015,IENS,".03")=DUZ
+77 ;
+78 DO FILE^DIE("","BJPNUPD","ERROR")
+79 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^Status PIP update change failed"_$CHAR(30)
GOTO XCPSTS
+80 DO FILE^DIE("","IPLUPD","ERROR")
+81 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^Status IPL update change failed"_$CHAR(30)
GOTO XCPSTS
+82 ;
+83 ;Broadcast update
+84 ;BJPN*2.0*7;Removed PPL
+85 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+86 DO FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
+87 ;
+88 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+89 ;
XCPSTS SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DEL(DATA,VIEN,PIPIEN,DCODE,DRSN,DELIPL) ;BJPN DELETE PIP PROBLEM
+1 ;
+2 ;Delete prenatal problem from PIP and IPL
+3 ;
+4 NEW UID,II,%,NOW,PRUPD,ERROR,RSLT,DFN,PROC,DTTM,VFL,VPUPD,PRBIEN,DIC,DA,X,Y,DLAYGO
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BJPNCPIP",UID))
+7 KILL @DATA
+8 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+9 ;
+10 SET II=0
+11 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER"
+12 ;
+13 SET @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+14 ;
+15 ;Input validation
+16 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VISIT IEN"_$CHAR(30)
GOTO XDEL
+17 IF $GET(PIPIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING PIPIEN"_$CHAR(30)
GOTO XDEL
+18 SET DELIPL=$GET(DELIPL)
+19 IF $$GET1^DIQ(90680.01,PIPIEN_",",".01","I")=""
SET II=II+1
SET @DATA@(II)="-1^INVALID PIPIEN"_$CHAR(30)
GOTO XDEL
+20 IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
SET II=II+1
SET @DATA@(II)="-1^PROBLEM ALREADY DELETED"_$CHAR(30)
GOTO XDEL
+21 SET DCODE=$GET(DCODE,"")
SET DRSN=$GET(DRSN,"")
+22 ;
+23 DO NOW^%DTC
SET NOW=%
+24 ;
+25 ;Retrieve DFN
+26 SET DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID VISIT"_$CHAR(30)
GOTO XDEL
+27 ;
+28 ;Get the problem (IPL) IEN
+29 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
IF PRBIEN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID IPL POINTER"_$CHAR(30)
GOTO XDEL
+30 ;
+31 ;Mark as deleted - PIP
+32 SET RSLT="1"
+33 SET PRUPD(90680.01,PIPIEN_",",2.01)=DUZ
+34 SET PRUPD(90680.01,PIPIEN_",",2.02)=NOW
+35 SET PRUPD(90680.01,PIPIEN_",",2.03)=DCODE
+36 SET PRUPD(90680.01,PIPIEN_",",2.04)=DRSN
+37 ;Remove from PIP column in IPL
SET PRUPD(9000011,PRBIEN_",",.19)="@"
+38 IF $DATA(PRUPD)
DO FILE^DIE("","PRUPD","ERROR")
+39 IF $DATA(ERROR)
SET RSLT="-1^PIP DELETE FAILED"
SET II=II+1
SET @DATA@(II)=RSLT_$CHAR(30)
GOTO XDEL
+40 ;
+41 ;
+42 ;Add the IPL PIP flag history
+43 SET DIC="^BJPNPL("_PIPIEN_",5,"
+44 SET DA(1)=PIPIEN
+45 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+46 SET X=NOW
+47 KILL DO,DD
DO FILE^DICN
+48 IF +Y=-1
SET II=II+1
SET @DATA@(II)="-1^Could not add PIP column history"
GOTO XDEL
+49 ;
+50 ;Mark as deleted - IPL
+51 SET RSLT="1"
+52 IF $GET(DELIPL)=1
Begin DoDot:1
+53 NEW IPLUPD
+54 SET IPLUPD(9000011,PRBIEN_",",.12)="D"
+55 SET IPLUPD(9000011,PRBIEN_",",2.01)=DUZ
+56 SET IPLUPD(9000011,PRBIEN_",",2.02)=NOW
+57 SET IPLUPD(9000011,PRBIEN_",",2.03)=DCODE
+58 SET IPLUPD(9000011,PRBIEN_",",2.04)=DRSN
+59 SET IPLUPD(9000011,PRBIEN_",",.03)=NOW
+60 SET IPLUPD(9000011,PRBIEN_",",.14)=DUZ
+61 DO FILE^DIE("","IPLUPD","ERROR")
+62 IF $DATA(ERROR)
SET RSLT="-1^IPL DELETE FAILED"
SET II=II+1
SET @DATA@(II)=RSLT_$CHAR(30)
End DoDot:1
IF RSLT'=1
GOTO XDEL
+63 ;
+64 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+65 ;
+66 ;Broadcast update
+67 ;BJPN*2.0*7;Remove PPL alert
+68 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+69 DO FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
+70 ;
XDEL SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
STS(DATA,PIPIEN,VIEN) ;EP - BJPN TOGGLE STATUS
+1 ;
+2 ;Toggle the PIP status of a problem
+3 ;
+4 NEW UID,II,STS,RESULT,PRBIEN,NSTS,PIP,BJPNUPD,ERROR,DFN,IPLUPD
+5 NEW DIC,DA,DLAYGO,X,Y,IENS
+6 ;
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BJPNCPIP",UID))
+9 KILL @DATA
+10 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+11 ;
+12 SET II=0
+13 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER"
+14 ;
+15 ;Define Header
+16 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+17 ;
+18 ;Input validation
+19 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VISIT IEN"_$CHAR(30)
GOTO XSTS
+20 IF $GET(PIPIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING PIPIEN"_$CHAR(30)
GOTO XSTS
+21 ;
+22 DO NOW^%DTC
SET NOW=%
+23 ;
+24 ;Get the problem (IPL) IEN
+25 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
IF PRBIEN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID IPL POINTER"_$CHAR(30)
GOTO XSTS
+26 SET DFN=$$GET1^DIQ(9000011,PRBIEN_",",.02,"I")
+27 ;
+28 ;Get the current status
+29 SET STS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+30 ;Default to "A" if null
IF STS'="A"
IF STS'="I"
SET STS="I"
+31 ;
+32 ;Define new values
+33 IF STS="A"
SET NSTS="I"
SET PIP="@"
+34 IF STS="I"
SET NSTS="A"
SET PIP=1
+35 SET BJPNUPD(90680.01,PIPIEN_",",.08)=NSTS
+36 SET BJPNUPD(9000011,PRBIEN_",",.19)=PIP
+37 SET IPLUPD(9000011,PRBIEN_",",.03)=NOW
+38 SET IPLUPD(9000011,PRBIEN_",",.14)=DUZ
+39 ;
+40 ;Add the IPL PIP flag
+41 SET DIC="^BJPNPL("_PIPIEN_",5,"
+42 SET DA(1)=PIPIEN
+43 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+44 SET X=NOW
+45 KILL DO,DD
DO FILE^DICN
+46 IF +Y=-1
SET II=II+1
SET @DATA@(II)="-1^Could not add PIP column history"
GOTO XSTS
+47 ;
+48 ;Add the User/PIP value
+49 SET DA(1)=PIPIEN
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+50 SET BJPNUPD(90680.015,IENS,".02")=$SELECT(PIP=1:1,1:0)
+51 SET BJPNUPD(90680.015,IENS,".03")=DUZ
+52 ;
+53 DO FILE^DIE("","BJPNUPD","ERROR")
+54 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^Status PIP update change failed"_$CHAR(30)
GOTO XSTS
+55 DO FILE^DIE("","IPLUPD","ERROR")
+56 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^Status IPL update change failed"_$CHAR(30)
GOTO XSTS
+57 ;
+58 ;Broadcast update
+59 ;BJPN*2.0*7;Remove PPL alert since it has been removed
+60 ;D FIREEV^BJPNPDET("","REFRESH")
+61 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+62 DO FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
+63 ;
+64 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+65 ;
XSTS SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
SCO(DATA,PIPIEN,VIEN) ;EP - BJPN TOGGLE SCOPE
+1 ;
+2 ;Toggle the PIP scope of a problem
+3 ;
+4 NEW UID,II,SCO,RESULT,PRBIEN,NSCO,BJPNUPD,ERROR,DFN,IPLUPD
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BJPNCPIP",UID))
+7 KILL @DATA
+8 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+9 ;
+10 SET II=0
+11 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNCPIP D UNWIND^%ZTER"
+12 ;
+13 ;Define Header
+14 SET @DATA@(II)="T00005RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+15 ;
+16 ;Input validation
+17 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VISIT IEN"_$CHAR(30)
GOTO XSCO
+18 IF $GET(PIPIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING PIPIEN"_$CHAR(30)
GOTO XSCO
+19 ;
+20 DO NOW^%DTC
SET NOW=%
+21 ;
+22 ;Get the problem (IPL) IEN
+23 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.1,"I")
IF PRBIEN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID IPL POINTER"_$CHAR(30)
GOTO XSCO
+24 SET DFN=$$GET1^DIQ(9000011,PRBIEN_",",.02,"I")
+25 ;
+26 ;Get the current scope
+27 SET SCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+28 IF SCO'="A"
IF SCO'="C"
SET SCO="A"
+29 ;
+30 ;Define new values
+31 IF SCO="A"
SET NSCO="C"
+32 IF SCO="C"
SET NSCO="A"
+33 SET BJPNUPD(90680.01,PIPIEN_",",.07)=NSCO
+34 SET IPLUPD(9000011,PRBIEN_",",.03)=NOW
+35 SET IPLUPD(9000011,PRBIEN_",",.14)=DUZ
+36 DO FILE^DIE("","BJPNUPD","ERROR")
+37 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^Scope change failed"_$CHAR(30)
GOTO XSCO
+38 DO FILE^DIE("","IPLUPD","ERROR")
+39 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^Scope change failed"_$CHAR(30)
GOTO XSCO
+40 ;
+41 ;Broadcast update
+42 ;D FIREEV^BJPNPDET("","REFRESH")
+43 ;BJPN*2.0*7;Remove refreshes as being handled by GUI
+44 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+45 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
+46 ;
+47 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+48 ;
XSCO 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
