BDMPL.m

BDMPL ; IHS/CMI/LAB - PROBLEM LIST UPDATE ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,8**;JUN 14, 2007;Build 53

 ;

 ;

EOJ ;cleanup

 D:$D(VALMWD) CLEAR^VALM1 ;clears out all list man stuff

 K ^TMP($J,"BDMPL"),^TMP($J,"APCDPL")

 D EN^XBVK("APCD")

 K XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW

 K DFN,BDMLOC,BDMPAT,BDMDATE,BDMPIEN,BDMAF,BDMPRB,APCDOVRR,BDMLOOK,BDMPDFN,APCDPLPT

 Q

EN1 ;EP

EN ;EP  main entry point for BDM PL PROBLEM LIST

 S VALMCC=1 ;1 means screen mode, 0 means scrolling mode

 D EN^VALM("BDM PCC PROBLEM LIST DISPLAY")

 D CLEAR^VALM1

 Q

 ;

HDR ;EP -- header code

 S VALMHDR(1)=$TR($J(" ",80)," ","-")

 S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(DFN,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1(AUPNDOB)_"   Sex: "_$P(^DPT(DFN,0),U,2)_"   HRN: "_$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"????")

 S VALMHDR(3)=$TR($J(" ",80)," ","-")

 Q

 ;

INIT ; -- init variables and list array

 K ^TMP($J,"BDMPL")

 S APCDPLPT=DFN

 D GATHER^APCDPL ;gather up all problems FROM PCC

 S VALMCNT=APCDLINE

 S BDMRCNT=APCDRCNT

 M ^TMP($J,"BDMPL")=^TMP($J,"APCDPL")

 ;S VALMCNT=BDMLINE ;this variable must be the total number of lines in list

 S APCDOVRR="" ;for provider narrative lookup

 Q

 ;

TEXT ;

 ;;Patient Care Component (PCC)

 ;;

 ;;***********************************

 ;;*  View PCC Patient Problem List  *

 ;;***********************************

 ;;

 Q

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 K ^TMP($J,"BDMPL")

 K BDMRCNT,BDMPL,BDMLINE,BDMX,BDMP0,BDMC,BDML,BDMLR,BDMPIEN,BDMAF,BDMPRB,APCDOVRR,BDMLOOK,BDMPDFN,BDMLOC,BDMDATE,APCDPLPT

 K X,Y

 K VALMHDR

 Q

 ;

EXPND ; -- expand code

 Q

GETPROB ;get record

 S BDMPIEN=0

 I 'BDMRCNT W !,"No problems to select." Q

 S DIR(0)="N^1:"_BDMRCNT_":0",DIR("A")="Select Problem" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) W !!,"No Problem Selected" D PAUSE,EXIT Q

 S BDMP=Y

 S (X,Y)=0 F  S X=$O(^TMP($J,"BDMPL","IDX",X)) Q:X'=+X!(BDMPIEN)  I $O(^TMP($J,"BDMPL","IDX",X,0))=BDMP S Y=$O(^TMP($J,"BDMPL","IDX",X,0)),BDMPIEN=^TMP($J,"BDMPL","IDX",X,Y)

 I '$D(^AUPNPROB(BDMPIEN,0)) W !,"Not a valid PCC PROBLEM." K BDMP S BDMPIEN=0 Q

 D FULL^VALM1 ;give me full control of screen

 Q

 ;

DD ;EP - called from protocol to display (DIQ) a problem in detail

 NEW BDMPIEN

 D GETPROB

 I 'BDMPIEN D PAUSE,XIT Q

 D DIQ^XBLM(9000011,BDMPIEN)

 D XIT

 Q

PAUSE ;EP

 S DIR(0)="EO",DIR("A")="Press return to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

GETNUM(P) ;EP - get problem number given ien of problem entry

 NEW N,F

 S N=""

 I 'P Q N

 I '$D(^AUPNPROB(P,0)) Q N

 S F=$P(^AUPNPROB(P,0),U,6)

 S N=$S($P(^AUTTLOC(F,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_$P(^AUPNPROB(P,0),U,7)

 Q N

XIT ;

 K APCDOVRR

 K DLAYGO

 K APCDPIEN

 D TERM^VALM0

 S VALMBCK="R"

 ;D INIT^BDMPL

 ;S VALMCNT=BDMLINE

 ;D HDR^BDMPL

 K BDMTEMP,BDMPRMT,BDMP,BDMPIEN,BDMAF,BDMF,BDMP0,BDMPRB,APCDLOOK,BDMPPTR

 ;D KDIE

 Q

BDMPL     ; IHS/CMI/LAB - PROBLEM LIST UPDATE ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,8**;JUN 14, 2007;Build 53

 +2       ;

 +3       ;

EOJ       ;cleanup

 +1       ;clears out all list man stuff

           IF $DATA(VALMWD)

               DO CLEAR^VALM1

 +2        KILL ^TMP($JOB,"BDMPL"),^TMP($JOB,"APCDPL")

 +3        DO EN^XBVK("APCD")

 +4        KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW

 +5        KILL DFN,BDMLOC,BDMPAT,BDMDATE,BDMPIEN,BDMAF,BDMPRB,APCDOVRR,BDMLOOK,BDMPDFN,APCDPLPT

 +6        QUIT 

EN1       ;EP

EN        ;EP  main entry point for BDM PL PROBLEM LIST

 +1       ;1 means screen mode, 0 means scrolling mode

           SET VALMCC=1

 +2        DO EN^VALM("BDM PCC PROBLEM LIST DISPLAY")

 +3        DO CLEAR^VALM1

 +4        QUIT 

 +5       ;

HDR       ;EP -- header code

 +1        SET VALMHDR(1)=$TRANSLATE($JUSTIFY(" ",80)," ","-")

 +2        SET VALMHDR(2)="Patient Name: "_IORVON_$PIECE(^DPT(DFN,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1(AUPNDOB)_"   Sex: "_$PIECE(^DPT(DFN,0),U,2)_"   HRN: "_$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"????")

 +3        SET VALMHDR(3)=$TRANSLATE($JUSTIFY(" ",80)," ","-")

 +4        QUIT 

 +5       ;

INIT      ; -- init variables and list array

 +1        KILL ^TMP($JOB,"BDMPL")

 +2        SET APCDPLPT=DFN

 +3       ;gather up all problems FROM PCC

           DO GATHER^APCDPL

 +4        SET VALMCNT=APCDLINE

 +5        SET BDMRCNT=APCDRCNT

 +6        MERGE ^TMP($JOB,"BDMPL")=^TMP($JOB,"APCDPL")

 +7       ;S VALMCNT=BDMLINE ;this variable must be the total number of lines in list

 +8       ;for provider narrative lookup

           SET APCDOVRR=""

 +9        QUIT 

 +10      ;

TEXT      ;

 +1       ;;Patient Care Component (PCC)

 +2       ;;

 +3       ;;***********************************

 +4       ;;*  View PCC Patient Problem List  *

 +5       ;;***********************************

 +6       ;;

 +7        QUIT 

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP($JOB,"BDMPL")

 +2        KILL BDMRCNT,BDMPL,BDMLINE,BDMX,BDMP0,BDMC,BDML,BDMLR,BDMPIEN,BDMAF,BDMPRB,APCDOVRR,BDMLOOK,BDMPDFN,BDMLOC,BDMDATE,APCDPLPT

 +3        KILL X,Y

 +4        KILL VALMHDR

 +5        QUIT 

 +6       ;

EXPND     ; -- expand code

 +1        QUIT 

GETPROB   ;get record

 +1        SET BDMPIEN=0

 +2        IF 'BDMRCNT

               WRITE !,"No problems to select."

               QUIT 

 +3        SET DIR(0)="N^1:"_BDMRCNT_":0"

           SET DIR("A")="Select Problem"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               WRITE !!,"No Problem Selected"

               DO PAUSE

               DO EXIT

               QUIT 

 +5        SET BDMP=Y

 +6        SET (X,Y)=0

           FOR 

               SET X=$ORDER(^TMP($JOB,"BDMPL","IDX",X))

               IF X'=+X!(BDMPIEN)

                   QUIT 

               IF $ORDER(^TMP($JOB,"BDMPL","IDX",X,0))=BDMP

                   SET Y=$ORDER(^TMP($JOB,"BDMPL","IDX",X,0))

                   SET BDMPIEN=^TMP($JOB,"BDMPL","IDX",X,Y)

 +7        IF '$DATA(^AUPNPROB(BDMPIEN,0))

               WRITE !,"Not a valid PCC PROBLEM."

               KILL BDMP

               SET BDMPIEN=0

               QUIT 

 +8       ;give me full control of screen

           DO FULL^VALM1

 +9        QUIT 

 +10      ;

DD        ;EP - called from protocol to display (DIQ) a problem in detail

 +1        NEW BDMPIEN

 +2        DO GETPROB

 +3        IF 'BDMPIEN

               DO PAUSE

               DO XIT

               QUIT 

 +4        DO DIQ^XBLM(9000011,BDMPIEN)

 +5        DO XIT

 +6        QUIT 

PAUSE     ;EP

 +1        SET DIR(0)="EO"

           SET DIR("A")="Press return to continue...."

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        QUIT 

GETNUM(P) ;EP - get problem number given ien of problem entry

 +1        NEW N,F

 +2        SET N=""

 +3        IF 'P

               QUIT N

 +4        IF '$DATA(^AUPNPROB(P,0))

               QUIT N

 +5        SET F=$PIECE(^AUPNPROB(P,0),U,6)

 +6        SET N=$SELECT($PIECE(^AUTTLOC(F,0),U,7)]"":$JUSTIFY($PIECE(^(0),U,7),4),1:"??")_$PIECE(^AUPNPROB(P,0),U,7)

 +7        QUIT N

XIT       ;

 +1        KILL APCDOVRR

 +2        KILL DLAYGO

 +3        KILL APCDPIEN

 +4        DO TERM^VALM0

 +5        SET VALMBCK="R"

 +6       ;D INIT^BDMPL

 +7       ;S VALMCNT=BDMLINE

 +8       ;D HDR^BDMPL

 +9        KILL BDMTEMP,BDMPRMT,BDMP,BDMPIEN,BDMAF,BDMF,BDMP0,BDMPRB,APCDLOOK,BDMPPTR

 +10      ;D KDIE

 +11       QUIT