BDPLMDSP.m

BDPLMDSP ; IHS/CMI/TMJ - UPDATE USING LISTMAN ;  

 ;;2.0;IHS PCC SUITE;**10,21**;MAY 14, 2009;Build 34

 ;

 ;

START ;

 W:$D(IOF) @IOF

 W $$CTR("View Designated Provider List",80)

PROV ;

 D ^XBFMK

 S BDPPAT=""

 W !! S DIC("A")="Enter Patient Name: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD

 I Y<0 W !,"No Patient Selected." Q

 S BDPPAT=+Y

 D EN

END ;

 D EOJ

 K BDPP,BDPQUIT,BDPW

 Q

 ;

PPEP(BDPPAT,BDPDETL) ;PEP - entry point to view/update one provider's panel

 I '$G(BDPPAT) Q

 S BDPDETL=$G(BDPDETL)

 ;D EN^XBNEW("EN^BDPLMDSP","BDPPAT")

 D EN

 Q

EN ; -- main entry point for BDP UPDATE PATIENT CASE DATA

 D EN^VALM("BDP DESG PROV DISP - 1 PAT")

 D EN^XBVK("BDP")

 Q

 ;

HDR ; -- header code

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

 S VALMHDR(2)="Designated Provider List for: "_IORVON_$P(^DPT(BDPPAT,0),U)_IORVOFF_"    HRN: "_$$HRN^AUPNPAT(BDPPAT,DUZ(2),2)

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

 S VALMHDR(4)="Category",$E(VALMHDR(4),32)="Current Provider",$E(VALMHDR(4),57)="Updated",$E(VALMHDR(4),66)="Updated by"

 Q

 ;

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

INIT ; -- init variables and list array

 S VALMSG="?? for more actions  + next screen  - prev screen"

 D GATHER ;gather up all records for display

 S VALMCNT=BDPLINE

 Q

 ;

GATHER ;

 K BDPLIST

 S BDPRCNT=0,BDPLINE=0

 S BDPD=0 F  S BDPD=$O(^BDPRECN("AA",BDPPAT,BDPD)) Q:BDPD'=+BDPD  D

 .S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPD,0))

 .;Q:$P($G(^BDPRECN(BDPX,0)),U,3)=""

 .S BDPRCNT=BDPRCNT+1,BDPLINE=BDPLINE+1,Y=""

 .S $E(Y,1)=$E($$VAL^XBDIQ1(90360.1,BDPX,.01),1,30)

 .S $E(Y,32)=$E($$VAL^XBDIQ1(90360.1,BDPX,.03),1,25)

 .;S BDPY=$P(^BDPRECN(BDPX,0),U,3)

 .;S $E(Y,57)=$E($$VAL^XBDIQ1(200,BDPY,53.5),1,13)

 .S $E(Y,57)=$$DATE($P(^BDPRECN(BDPX,0),U,5))

 .S $E(Y,66)=$$VAL^XBDIQ1(90360.1,BDPX,.04)

 .S BDPLIST(BDPLINE,0)=Y,BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 .Q:'$G(BDPDETL)

 .S BDPLINE=BDPLINE+1

 .S BDPLIST(BDPLINE,0)=IORVON_" History Detail:"_IORVOFF,BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 .S BDPLINE=BDPLINE+1

 .S BDPLIST(BDPLINE,0)=" Previous Provider",$E(BDPLIST(BDPLINE,0),34)="Start Date",$E(BDPLIST(BDPLINE,0),45)="Stop Date",$E(BDPLIST(BDPLINE,0),57)="Updated",$E(BDPLIST(BDPLINE,0),66)="Updated by",BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 .S BDPZ=0 F  S BDPZ=$O(^BDPRECN(BDPX,1,BDPZ)) Q:BDPZ'=+BDPZ  D

 ..S BDPN=^BDPRECN(BDPX,1,BDPZ,0)

 ..S BDPLINE=BDPLINE+1

 ..S BDPY="",$E(BDPY,2)=$E($P(^VA(200,$P(BDPN,U),0),U),1,22)

 ..S $E(BDPY,34)=$S($P(BDPN,U,4):$$DATE($P(BDPN,U,4)),1:"Unknown")

 ..S $E(BDPY,45)=$S($P(BDPN,U,5):$$DATE($P(BDPN,U,5)),1:"")

 ..I $P(BDPN,U,3) S $E(BDPY,57)=$$DATE($P(BDPN,U,3))

 ..I $P(BDPN,U,2) S $E(BDPY,66)=$E($P(^VA(200,$P(BDPN,U,2),0),U),1,20)

 ..S BDPLIST(BDPLINE,0)=BDPY,BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 .S BDPLINE=BDPLINE+1,BDPLIST(BDPLINE,0)=" ",BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 Q

 ;

EOJ ;

 D EN^XBVK("BDP")

 K DFN

 K DDSFILE,DIPGM,Y

 K X,Y,%,DR,DDS,DA,DIC

 K BDPCASE,BDPX,BDPD,BDPRCNT,BDPLINE,BDPCDATE

 D:$D(VALMWD) CLEAR^VALM1

 K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,VALMON,VALMEVL,VALMIOXY

 D KILL^AUPNPAT

 Q

 ;

EXPND ; -- expand code

 Q

 ;

EXIT ;

 Q

HELP ;EP -- help code

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

 Q

 ;

DATE(D) ;EP

 I D="" Q ""

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)

 ;

BDPLMDSP  ; IHS/CMI/TMJ - UPDATE USING LISTMAN ;  

 +1       ;;2.0;IHS PCC SUITE;**10,21**;MAY 14, 2009;Build 34

 +2       ;

 +3       ;

START     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE $$CTR("View Designated Provider List",80)

PROV      ;

 +1        DO ^XBFMK

 +2        SET BDPPAT=""

 +3        WRITE !!

           SET DIC("A")="Enter Patient Name: "

           SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA,DR,DLAYGO,DIADD

 +4        IF Y<0

               WRITE !,"No Patient Selected."

               QUIT 

 +5        SET BDPPAT=+Y

 +6        DO EN

END       ;

 +1        DO EOJ

 +2        KILL BDPP,BDPQUIT,BDPW

 +3        QUIT 

 +4       ;

PPEP(BDPPAT,BDPDETL) ;PEP - entry point to view/update one provider's panel

 +1        IF '$GET(BDPPAT)

               QUIT 

 +2        SET BDPDETL=$GET(BDPDETL)

 +3       ;D EN^XBNEW("EN^BDPLMDSP","BDPPAT")

 +4        DO EN

 +5        QUIT 

EN        ; -- main entry point for BDP UPDATE PATIENT CASE DATA

 +1        DO EN^VALM("BDP DESG PROV DISP - 1 PAT")

 +2        DO EN^XBVK("BDP")

 +3        QUIT 

 +4       ;

HDR       ; -- header code

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

 +2        SET VALMHDR(2)="Designated Provider List for: "_IORVON_$PIECE(^DPT(BDPPAT,0),U)_IORVOFF_"    HRN: "_$$HRN^AUPNPAT(BDPPAT,DUZ(2),2)

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

 +4        SET VALMHDR(4)="Category"

           SET $EXTRACT(VALMHDR(4),32)="Current Provider"

           SET $EXTRACT(VALMHDR(4),57)="Updated"

           SET $EXTRACT(VALMHDR(4),66)="Updated by"

 +5        QUIT 

 +6       ;

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

INIT      ; -- init variables and list array

 +1        SET VALMSG="?? for more actions  + next screen  - prev screen"

 +2       ;gather up all records for display

           DO GATHER

 +3        SET VALMCNT=BDPLINE

 +4        QUIT 

 +5       ;

GATHER    ;

 +1        KILL BDPLIST

 +2        SET BDPRCNT=0

           SET BDPLINE=0

 +3        SET BDPD=0

           FOR 

               SET BDPD=$ORDER(^BDPRECN("AA",BDPPAT,BDPD))

               IF BDPD'=+BDPD

                   QUIT 

               Begin DoDot:1

 +4                SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPD,0))

 +5       ;Q:$P($G(^BDPRECN(BDPX,0)),U,3)=""

 +6                SET BDPRCNT=BDPRCNT+1

                   SET BDPLINE=BDPLINE+1

                   SET Y=""

 +7                SET $EXTRACT(Y,1)=$EXTRACT($$VAL^XBDIQ1(90360.1,BDPX,.01),1,30)

 +8                SET $EXTRACT(Y,32)=$EXTRACT($$VAL^XBDIQ1(90360.1,BDPX,.03),1,25)

 +9       ;S BDPY=$P(^BDPRECN(BDPX,0),U,3)

 +10      ;S $E(Y,57)=$E($$VAL^XBDIQ1(200,BDPY,53.5),1,13)

 +11               SET $EXTRACT(Y,57)=$$DATE($PIECE(^BDPRECN(BDPX,0),U,5))

 +12               SET $EXTRACT(Y,66)=$$VAL^XBDIQ1(90360.1,BDPX,.04)

 +13               SET BDPLIST(BDPLINE,0)=Y

                   SET BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 +14               IF '$GET(BDPDETL)

                       QUIT 

 +15               SET BDPLINE=BDPLINE+1

 +16               SET BDPLIST(BDPLINE,0)=IORVON_" History Detail:"_IORVOFF

                   SET BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 +17               SET BDPLINE=BDPLINE+1

 +18               SET BDPLIST(BDPLINE,0)=" Previous Provider"

                   SET $EXTRACT(BDPLIST(BDPLINE,0),34)="Start Date"

                   SET $EXTRACT(BDPLIST(BDPLINE,0),45)="Stop Date"

                   SET $EXTRACT(BDPLIST(BDPLINE,0),57)="Updated"

                   SET $EXTRACT(BDPLIST(BDPLINE,0),66)="Updated by"

                   SET BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

 +19               SET BDPZ=0

                   FOR 

                       SET BDPZ=$ORDER(^BDPRECN(BDPX,1,BDPZ))

                       IF BDPZ'=+BDPZ

                           QUIT 

                       Begin DoDot:2

 +20                       SET BDPN=^BDPRECN(BDPX,1,BDPZ,0)

 +21                       SET BDPLINE=BDPLINE+1

 +22                       SET BDPY=""

                           SET $EXTRACT(BDPY,2)=$EXTRACT($PIECE(^VA(200,$PIECE(BDPN,U),0),U),1,22)

 +23                       SET $EXTRACT(BDPY,34)=$SELECT($PIECE(BDPN,U,4):$$DATE($PIECE(BDPN,U,4)),1:"Unknown")

 +24                       SET $EXTRACT(BDPY,45)=$SELECT($PIECE(BDPN,U,5):$$DATE($PIECE(BDPN,U,5)),1:"")

 +25                       IF $PIECE(BDPN,U,3)

                               SET $EXTRACT(BDPY,57)=$$DATE($PIECE(BDPN,U,3))

 +26                       IF $PIECE(BDPN,U,2)

                               SET $EXTRACT(BDPY,66)=$EXTRACT($PIECE(^VA(200,$PIECE(BDPN,U,2),0),U),1,20)

 +27                       SET BDPLIST(BDPLINE,0)=BDPY

                           SET BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

                       End DoDot:2

 +28               SET BDPLINE=BDPLINE+1

                   SET BDPLIST(BDPLINE,0)=" "

                   SET BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX

               End DoDot:1

 +29       QUIT 

 +30      ;

EOJ       ;

 +1        DO EN^XBVK("BDP")

 +2        KILL DFN

 +3        KILL DDSFILE,DIPGM,Y

 +4        KILL X,Y,%,DR,DDS,DA,DIC

 +5        KILL BDPCASE,BDPX,BDPD,BDPRCNT,BDPLINE,BDPCDATE

 +6        IF $DATA(VALMWD)

               DO CLEAR^VALM1

 +7        KILL VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,VALMON,VALMEVL,VALMIOXY

 +8        DO KILL^AUPNPAT

 +9        QUIT 

 +10      ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

EXIT      ;

 +1        QUIT 

HELP      ;EP -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

DATE(D)   ;EP

 +1        IF D=""

               QUIT ""

 +2        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)

 +3       ;