AMHBPL3.m

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      ;