AMHBPL3 ; IHS/CMI/LAB - problem list update from list manager ;
;;4.0;IHS BEHAVIORAL HEALTH;**2**;JUN 18, 2010;Build 23
;
NAP ;EP - called from protocol to add a problem to problem list
NEW AMHPRV,AMHD
D FULL^VALM1
I $$ANYACTP^AMHAPRB(AMHPAT) D Q
.W !!,"There are ACTIVE Problems on this patient's BH Problem list. You"
.W !,"cannot use this action item."
.D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
NAPDE1 ;EP - called from xbnew
S DIR(0)="Y",DIR("A")="Did the Provider indicate that the patient has No Active BH Problems",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"No action taken." D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
I 'Y W !,"No action taken." D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Provider documented 'No Active BH Problems'"
S DIR("B")=$$FMTE^XLFDT(DT),DIR("?")="This is the visit date or the date the provider provided the information."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G NAPDE1
I $P(Y,".")>DT W !!,"Future Dates not allowed.",! G NAPDE1
S AMHD=Y
NAPDE1P ;GET PROVIDER
S DIR(0)="9002011.14,1204",DIR("A")="Enter the PROVIDER who documented 'No Active BH Problems'"
S DIR("B")=$$PRIMPROV^AMHUTIL(AMHR,"N") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G NAPDE1P
S AMHPRV=+Y
D NAPADD(AMHR,AMHPAT,AMHD,AMHPRV,.AMHRET)
I $P(AMHRET,U,1)=0 W !!,"error: ",$P(AMHRET,U,2)
D PAUSE^AMHBPL1,EXIT^AMHBPL1
Q
NAPADD(AMHV,AMHP,AMHD,AMHPRV,RETVAL) ;PEP - called to update BH Problem list update fields
;this API can be called to have a MHSS RECORD UPDATED/REVIEWED entry and populate the
;
;RETURN VALUE:
; ien of MHSS RECORD UPDATED/REVIEWED entry that was created
; or 0^error message
S AMHV=$G(AMHV)
S AMHP=$G(AMHP)
I 'AMHP S RETVAL="0^not a valid patient DFN" Q
I '$D(^AUPNPAT(AMHP,0)) S RETVAL="0^not a valid patient DFN" Q
S AMHD=$G(AMHD)
I 'AMHD S RETVAL="0^no valid date passed" Q
S AMHPRV=$G(AMHPRV)
I 'AMHPRV S RETVAL="0^no valid provider ien passed" Q
S RETVAL=""
;
I AMHV D NAPV Q
Q
NAPV ;have a visit so create a MHSS RECORD updated/reviewed for provider AMHPRV if one does
;not exist on this visit already.
NEW AMHX,AMHVD,AMHVRI,AMHVAL
S AMHVAL=$O(^AUTTCRA("C","NAP",0))
I AMHVAL="" S RETVAL="0^action item missing" Q
S AMHVRI=""
S AMHX=0 F S AMHX=$O(^AMHRRUP("AD",AMHV,AMHX)) Q:AMHX=""!(AMHVRI) D
.;is this entry a problem list review entry?
.Q:$P(^AMHRRUP(AMHX,0),U,1)'=AMHVAL ;this one isn't a NAP entry
.Q:$P($G(^AMHRRUP(AMHX,2)),U,1)
.Q:$P($G(^AMHRRUP(AMHX,12)),U,4)'=AMHPRV ;not this provider
.S AMHVRI=AMHX ;found one so don't create one
.Q
I AMHVRI S RETVAL=AMHVRI D PLRV Q
S DIC="^AMHRRUP(",X=AMHVAL,DIC("DR")=".02////"_AMHP_";.03////"_AMHV_";1201////"_AMHD_";1204////"_AMHPRV,DIADD=1,DLAYGO=9002011.14,DIC(0)="EL"
D FILE^DICN
K DLAYGO,DIADD,DIC,DA
D PLRV
Q
PLR ;EP - called from protocol to add a problem to problem list
NEW AMHPIEN,AMHNDT
D FULL^VALM1
PLRDE1 ;EP - called from xbnew
S DIR(0)="Y",DIR("A")="Did the Provider indicate that he/she reviewed the Problem List",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"No action taken." D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
I 'Y W !,"No action taken." D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Provider Reviewed the Problem List"
S DIR("B")=$$FMTE^XLFDT(DT),DIR("?")="This is the visit date or the date the provider provided the information."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G PLRDE1
I $P(Y,".")>DT W !!,"Future Dates not allowed.",! G PLRDE1
S AMHD=Y
PLRDE1P ;GET PROVIDER
S DIR(0)="9002011.14,1204",DIR("A")="Enter the PROVIDER who Reviewed the Problem List"
S DIR("B")=$$PRIMPROV^AMHUTIL(AMHR,"N") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G PLRDE1P
S AMHPRV=+Y
D PLRADD(AMHR,AMHPAT,AMHD,AMHPRV,.AMHRET)
I $P(AMHRET,U,1)=0 W !!,"error: ",$P(AMHRET,U,2)
D PAUSE^AMHBPL1,EXIT^AMHBPL1
Q
PLRADD(AMHV,AMHP,AMHD,AMHPRV,RETVAL) ;PEP - called to update Problem list update fields
;this API can be called to have a V UPDATED/REVIEWED entry and populate the
;
;RETURN VALUE:
; ien of V UPDATED/REVIEWED entry that was created
; or 0^error message
S AMHPIEN=$G(AMHPIEN)
S AMHV=$G(AMHV)
S AMHP=$G(AMHP)
I 'AMHP S RETVAL="0^not a valid patient DFN" Q
I '$D(^AUPNPAT(AMHP,0)) S RETVAL="0^not a valid patient DFN" Q
S AMHD=$G(AMHD)
I 'AMHD S RETVAL="0^no valid date passed" Q
S AMHPRV=$G(AMHPRV)
I 'AMHPRV S RETVAL="0^no valid provider ien passed" Q
S RETVAL=""
;
I AMHV D PLRV Q
Q
PLRV ;have a visit so create a v updated/reviewed for provider AMHPRV if one does
;not exist on this visit already.
NEW AMHX,AMHVD,AMHVRI,AMHVAL
S AMHVAL=$O(^AUTTCRA("C","PLR",0))
I AMHVAL="" S RETVAL="0^action item missing" Q
S AMHVRI=""
S AMHX=0 F S AMHX=$O(^AMHRRUP("AD",AMHV,AMHX)) Q:AMHX=""!(AMHVRI) D
.;is this entry a problem list review entry?
.Q:$P(^AMHRRUP(AMHX,0),U,1)'=AMHVAL ;this one isn't a PLR entry
.Q:$P($G(^AMHRRUP(AMHX,2)),U,1)
.Q:$P($G(^AMHRRUP(AMHX,12)),U,4)'=AMHPRV ;not this provider
.S AMHVRI=AMHX ;found one so don't create one
.Q
I AMHVRI S RETVAL=AMHVRI Q
S DIC="^AMHRRUP(",X=AMHVAL,DIC("DR")=".02////"_AMHP_";.03////"_AMHV_";1201////"_AMHD_";1204////"_AMHPRV,DIADD=1,DLAYGO=9002011.14,DIC(0)="EL"
D FILE^DICN
K DLAYGO,DIADD,DIC,DA
Q
;
AMHBPL3 ; IHS/CMI/LAB - problem list update from list manager ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2**;JUN 18, 2010;Build 23
+2 ;
NAP ;EP - called from protocol to add a problem to problem list
+1 NEW AMHPRV,AMHD
+2 DO FULL^VALM1
+3 IF $$ANYACTP^AMHAPRB(AMHPAT)
Begin DoDot:1
+4 WRITE !!,"There are ACTIVE Problems on this patient's BH Problem list. You"
+5 WRITE !,"cannot use this action item."
+6 DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
QUIT
End DoDot:1
QUIT
NAPDE1 ;EP - called from xbnew
+1 SET DIR(0)="Y"
SET DIR("A")="Did the Provider indicate that the patient has No Active BH Problems"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
WRITE !,"No action taken."
DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
QUIT
+3 IF 'Y
WRITE !,"No action taken."
DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
QUIT
+4 SET DIR(0)="D^::EPTSX"
SET DIR("A")="Enter the Date the Provider documented 'No Active BH Problems'"
+5 SET DIR("B")=$$FMTE^XLFDT(DT)
SET DIR("?")="This is the visit date or the date the provider provided the information."
+6 KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO NAPDE1
+8 IF $PIECE(Y,".")>DT
WRITE !!,"Future Dates not allowed.",!
GOTO NAPDE1
+9 SET AMHD=Y
NAPDE1P ;GET PROVIDER
+1 SET DIR(0)="9002011.14,1204"
SET DIR("A")="Enter the PROVIDER who documented 'No Active BH Problems'"
+2 SET DIR("B")=$$PRIMPROV^AMHUTIL(AMHR,"N")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO NAPDE1P
+4 SET AMHPRV=+Y
+5 DO NAPADD(AMHR,AMHPAT,AMHD,AMHPRV,.AMHRET)
+6 IF $PIECE(AMHRET,U,1)=0
WRITE !!,"error: ",$PIECE(AMHRET,U,2)
+7 DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
+8 QUIT
NAPADD(AMHV,AMHP,AMHD,AMHPRV,RETVAL) ;PEP - called to update BH Problem list update fields
+1 ;this API can be called to have a MHSS RECORD UPDATED/REVIEWED entry and populate the
+2 ;
+3 ;RETURN VALUE:
+4 ; ien of MHSS RECORD UPDATED/REVIEWED entry that was created
+5 ; or 0^error message
+6 SET AMHV=$GET(AMHV)
+7 SET AMHP=$GET(AMHP)
+8 IF 'AMHP
SET RETVAL="0^not a valid patient DFN"
QUIT
+9 IF '$DATA(^AUPNPAT(AMHP,0))
SET RETVAL="0^not a valid patient DFN"
QUIT
+10 SET AMHD=$GET(AMHD)
+11 IF 'AMHD
SET RETVAL="0^no valid date passed"
QUIT
+12 SET AMHPRV=$GET(AMHPRV)
+13 IF 'AMHPRV
SET RETVAL="0^no valid provider ien passed"
QUIT
+14 SET RETVAL=""
+15 ;
+16 IF AMHV
DO NAPV
QUIT
+17 QUIT
NAPV ;have a visit so create a MHSS RECORD updated/reviewed for provider AMHPRV if one does
+1 ;not exist on this visit already.
+2 NEW AMHX,AMHVD,AMHVRI,AMHVAL
+3 SET AMHVAL=$ORDER(^AUTTCRA("C","NAP",0))
+4 IF AMHVAL=""
SET RETVAL="0^action item missing"
QUIT
+5 SET AMHVRI=""
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRRUP("AD",AMHV,AMHX))
IF AMHX=""!(AMHVRI)
QUIT
Begin DoDot:1
+7 ;is this entry a problem list review entry?
+8 ;this one isn't a NAP entry
IF $PIECE(^AMHRRUP(AMHX,0),U,1)'=AMHVAL
QUIT
+9 IF $PIECE($GET(^AMHRRUP(AMHX,2)),U,1)
QUIT
+10 ;not this provider
IF $PIECE($GET(^AMHRRUP(AMHX,12)),U,4)'=AMHPRV
QUIT
+11 ;found one so don't create one
SET AMHVRI=AMHX
+12 QUIT
End DoDot:1
+13 IF AMHVRI
SET RETVAL=AMHVRI
DO PLRV
QUIT
+14 SET DIC="^AMHRRUP("
SET X=AMHVAL
SET DIC("DR")=".02////"_AMHP_";.03////"_AMHV_";1201////"_AMHD_";1204////"_AMHPRV
SET DIADD=1
SET DLAYGO=9002011.14
SET DIC(0)="EL"
+15 DO FILE^DICN
+16 KILL DLAYGO,DIADD,DIC,DA
+17 DO PLRV
+18 QUIT
PLR ;EP - called from protocol to add a problem to problem list
+1 NEW AMHPIEN,AMHNDT
+2 DO FULL^VALM1
PLRDE1 ;EP - called from xbnew
+1 SET DIR(0)="Y"
SET DIR("A")="Did the Provider indicate that he/she reviewed the Problem List"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
WRITE !,"No action taken."
DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
QUIT
+3 IF 'Y
WRITE !,"No action taken."
DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
QUIT
+4 SET DIR(0)="D^::EPTSX"
SET DIR("A")="Enter the Date the Provider Reviewed the Problem List"
+5 SET DIR("B")=$$FMTE^XLFDT(DT)
SET DIR("?")="This is the visit date or the date the provider provided the information."
+6 KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO PLRDE1
+8 IF $PIECE(Y,".")>DT
WRITE !!,"Future Dates not allowed.",!
GOTO PLRDE1
+9 SET AMHD=Y
PLRDE1P ;GET PROVIDER
+1 SET DIR(0)="9002011.14,1204"
SET DIR("A")="Enter the PROVIDER who Reviewed the Problem List"
+2 SET DIR("B")=$$PRIMPROV^AMHUTIL(AMHR,"N")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO PLRDE1P
+4 SET AMHPRV=+Y
+5 DO PLRADD(AMHR,AMHPAT,AMHD,AMHPRV,.AMHRET)
+6 IF $PIECE(AMHRET,U,1)=0
WRITE !!,"error: ",$PIECE(AMHRET,U,2)
+7 DO PAUSE^AMHBPL1
DO EXIT^AMHBPL1
+8 QUIT
PLRADD(AMHV,AMHP,AMHD,AMHPRV,RETVAL) ;PEP - called to update Problem list update fields
+1 ;this API can be called to have a V UPDATED/REVIEWED entry and populate the
+2 ;
+3 ;RETURN VALUE:
+4 ; ien of V UPDATED/REVIEWED entry that was created
+5 ; or 0^error message
+6 SET AMHPIEN=$GET(AMHPIEN)
+7 SET AMHV=$GET(AMHV)
+8 SET AMHP=$GET(AMHP)
+9 IF 'AMHP
SET RETVAL="0^not a valid patient DFN"
QUIT
+10 IF '$DATA(^AUPNPAT(AMHP,0))
SET RETVAL="0^not a valid patient DFN"
QUIT
+11 SET AMHD=$GET(AMHD)
+12 IF 'AMHD
SET RETVAL="0^no valid date passed"
QUIT
+13 SET AMHPRV=$GET(AMHPRV)
+14 IF 'AMHPRV
SET RETVAL="0^no valid provider ien passed"
QUIT
+15 SET RETVAL=""
+16 ;
+17 IF AMHV
DO PLRV
QUIT
+18 QUIT
PLRV ;have a visit so create a v updated/reviewed for provider AMHPRV if one does
+1 ;not exist on this visit already.
+2 NEW AMHX,AMHVD,AMHVRI,AMHVAL
+3 SET AMHVAL=$ORDER(^AUTTCRA("C","PLR",0))
+4 IF AMHVAL=""
SET RETVAL="0^action item missing"
QUIT
+5 SET AMHVRI=""
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRRUP("AD",AMHV,AMHX))
IF AMHX=""!(AMHVRI)
QUIT
Begin DoDot:1
+7 ;is this entry a problem list review entry?
+8 ;this one isn't a PLR entry
IF $PIECE(^AMHRRUP(AMHX,0),U,1)'=AMHVAL
QUIT
+9 IF $PIECE($GET(^AMHRRUP(AMHX,2)),U,1)
QUIT
+10 ;not this provider
IF $PIECE($GET(^AMHRRUP(AMHX,12)),U,4)'=AMHPRV
QUIT
+11 ;found one so don't create one
SET AMHVRI=AMHX
+12 QUIT
End DoDot:1
+13 IF AMHVRI
SET RETVAL=AMHVRI
QUIT
+14 SET DIC="^AMHRRUP("
SET X=AMHVAL
SET DIC("DR")=".02////"_AMHP_";.03////"_AMHV_";1201////"_AMHD_";1204////"_AMHPRV
SET DIADD=1
SET DLAYGO=9002011.14
SET DIC(0)="EL"
+15 DO FILE^DICN
+16 KILL DLAYGO,DIADD,DIC,DA
+17 QUIT
+18 ;
