BWUINC ; IHS/CMI/LAB/PLS - update income status ;06-Oct-2003 15:36;DKM
;;2.0;WOMEN'S HEALTH;**8,9**;SEP 21, 2001
;
;
EP1(DFN) ;EP - CALLED FROM PROTOCOL
Q:'$G(DFN)
Q:'$D(^DPT(DFN))
Q:$P(^DPT(DFN,0),U,19)
D EN
D FULL^VALM1
K VALMHDR
Q
EP ;EP CALLED FROM DATA ENTRY
Q:'$G(BWPAT)
S DFN=BWPAT
N BWR
S Y=BWPAT D ^AUPNPAT
D EN
Q
START ;EP - update case data
K BWCASE,BWX,BWY
W:$D(IOF) @IOF W !!,"*** Update Patient Income Category Data ***",!!
S DFN="" F D GETPAT Q:DFN="" D EN,FULL^VALM1,EXIT
D EOJ
Q
EN ; -- main entry point for BW UPDATE PATIENT CASE DATA
D EN^VALM("BW UPDATE INCOME/RACE")
K BWCASE,BWX,BWD,BWRCNT,BWLINE,BWDN
Q
;
HDR ; -- header code
S VALMHDR(1)=$TR($J(" ",80)," ","-")
S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(DFN,0),U)_IOINORM_" DOB: "_$$FTIME^VALM1($P(^DPT(DFN,0),U,3))_" 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 Y=0,X="" F S Y=$O(^BWP(DFN,2,Y)) Q:Y'=+Y S Z=$P(^BWP(DFN,2,Y,0),U) I Z S X=X_$P($G(^BWRACE(Z,0)),U)_" "
S VALMHDR(3)="Race: "_X
S VALMHDR(4)=$TR($J(" ",80)," ","-")
S VALMHDR(5)=""
S VALMHDR(6)="# DATE ENTERED INCOME CATEGORY # IN HOUSEHOLD"
Q
;
GETPAT ;
;W:$D(IOF) @IOF
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
I Y<0 Q
;I '$D(^BWP(+Y,0)) W !!,"This patient is not on the Women's Health Register. Cannot update.",! H 2 S DFN="" Q
S DFN=+Y
Q
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=BWLINE
Q
;
GATHER ;
K BWCASE
S BWRCNT=0,BWLINE=0
S BWD=0 F S BWD=$O(^AUPNINCS("AA",DFN,BWD)) Q:BWD'=+BWD D
.S BWX=0 F S BWX=$O(^AUPNINCS("AA",DFN,BWD,BWX)) Q:BWX'=+BWX D
..S BWY=0 F S BWY=$O(^AUPNINCS("AA",DFN,BWD,BWX,BWY)) Q:BWY'=+BWY D
...S BWRCNT=BWRCNT+1,BWLINE=BWLINE+1,%=^AUPNINCS(BWY,0),Y=BWRCNT
...S $E(Y,5)=$$VAL^XBDIQ1(9000026,BWY,.03),$E(Y,24)=$$VAL^XBDIQ1(9000026,BWY,.01),$E(Y,42)=$$VAL^XBDIQ1(9000026,BWY,.04)
...S BWCASE(BWLINE,0)=Y,BWCASE("IDX",BWLINE,BWRCNT)=BWY
Q
GETIS ;
W !!
S BWDN="",DIR(0)="9000026,.01",DIR("A")="Enter INCOME CATEGORY" KILL DA D ^DIR KILL DIR
Q:$D(DIRUT)
S BWDN=Y
Q
ADD ;EP called from protocol to open a new case
D FULL^VALM1
W:$D(IOF) @IOF
W !!!!,"Adding New Income Status Entry for ",$P(^DPT(DFN,0),U),!!
D GETIS
Q:BWDN=""
W !,"Adding Income Status..." K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AUPNINCS(",DLAYGO=9000026,DIADD=1,X=BWDN,DIC("DR")=".02////"_DFN_";.03//"_$$FMTE^XLFDT(DT)_";.04"
D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Adding Income Status entry failed Record failed !! Deleting Record.",! D PAUSE Q
S BWPC=+Y
D EXIT
Q
EDIT ;
S BWPC=0
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S BWR1=$O(VALMY(0)) I 'BWR1 K BWR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(BWCASE("IDX",X)) Q:X'=+X!(BWPC) I $O(BWCASE("IDX",X,0))=BWR1 S Y=$O(BWCASE("IDX",X,0)),BWPC=BWCASE("IDX",X,Y)
I '$D(^AUPNINCS(BWPC,0)) W !,"Not a valid INCOME STATUS RECORD." K BWR D PAUSE D EXIT Q
D FULL^VALM1
S DA=BWPC,DIE="^AUPNINCS(",DR=".01;.03;.04" D ^DIE
D EXIT
Q
UR ;EP - called from protocol
I '$G(DFN) W !!,"DFN undefined!" D PAUSE,EXIT Q
I $O(^BWP(DFN,2,0)) W !!,"Race values currently entered for this patient:"
S X=0 F S X=$O(^BWP(DFN,2,X)) Q:X'=+X W !?10 S Y=$P(^BWP(DFN,2,X,0),U) I Y W $P(^BWRACE(Y,0),U)
D FULL^VALM1
D ^XBFMK
S DIE="^BWP(",DA=DFN,DR=2 D ^DIE
D ^XBFMK
D EXIT
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K BWX,BWCASE,BWPC,BWR1,BWY
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=BWLINE
D HDR
K X,Y,Z,I
Q
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
EOJ ;
K DDSFILE,DIPGM,Y
K X,Y,%,DR,DDS,DA,DIC
K BWCASE,BWX,BWD,BWRCNT,BWLINE,BWDN
D:$D(VALMWD) CLEAR^VALM1
K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
D KILL^AUPNPAT
Q
;
INCV(V,F) ;EP - patient's income level at date of visit v
I $G(F)="" S F="I"
I '$G(V) Q ""
NEW X,Y,Z,P
I '$D(^AUPNVSIT(V,0)) Q ""
S P=$P(^AUPNVSIT(V,0),U,5)
S D=$P($P(^AUPNVSIT(V,0),U),".")
S X=0,Y="" F S X=$O(^AUPNINCS("AA",P,X)) Q:X'=+X!(Y) D
.S Z=0 F S Z=$O(^AUPNINCS("AA",P,X,Z)) Q:Z'=+Z!(Y) D
..I (9999999-X)'>D S Y=$O(^AUPNINCS("AA",P,X,Z,0))
..Q
.Q
I Y="" Q ""
Q $S(F="I":$$VALI^XBDIQ1(9000026,Y,.01),1:$$VAL^XBDIQ1(9000026,Y,.01))
I 'P Q ""
INCWH(V,F) ;EP - income stat at procedure date
I $G(F)="" S F="I"
I '$G(V) Q ""
NEW X,Y,Z,P
I '$D(^BWPCD(V,0)) Q ""
S P=$P(^BWPCD(V,0),U,2)
S D=$P($P(^BWPCD(V,0),U,12),".")
S X=0,Y="" F S X=$O(^AUPNINCS("AA",P,X)) Q:X'=+X!(Y) D
.S Z=0 F S Z=$O(^AUPNINCS("AA",P,X,Z)) Q:Z'=+Z!(Y) D
..I (9999999-X)'>D S Y=$O(^AUPNINCS("AA",P,X,Z,0))
..Q
.Q
I Y="" Q ""
Q $S(F="I":$$VALI^XBDIQ1(9000026,Y,.01),1:$$VAL^XBDIQ1(9000026,Y,.01))
I 'P Q ""
EXPND ; -- expand code
Q
;
BWUINC ; IHS/CMI/LAB/PLS - update income status ;06-Oct-2003 15:36;DKM
+1 ;;2.0;WOMEN'S HEALTH;**8,9**;SEP 21, 2001
+2 ;
+3 ;
EP1(DFN) ;EP - CALLED FROM PROTOCOL
+1 IF '$GET(DFN)
QUIT
+2 IF '$DATA(^DPT(DFN))
QUIT
+3 IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+4 DO EN
+5 DO FULL^VALM1
+6 KILL VALMHDR
+7 QUIT
EP ;EP CALLED FROM DATA ENTRY
+1 IF '$GET(BWPAT)
QUIT
+2 SET DFN=BWPAT
+3 NEW BWR
+4 SET Y=BWPAT
DO ^AUPNPAT
+5 DO EN
+6 QUIT
START ;EP - update case data
+1 KILL BWCASE,BWX,BWY
+2 IF $DATA(IOF)
WRITE @IOF
WRITE !!,"*** Update Patient Income Category Data ***",!!
+3 SET DFN=""
FOR
DO GETPAT
IF DFN=""
QUIT
DO EN
DO FULL^VALM1
DO EXIT
+4 DO EOJ
+5 QUIT
EN ; -- main entry point for BW UPDATE PATIENT CASE DATA
+1 DO EN^VALM("BW UPDATE INCOME/RACE")
+2 KILL BWCASE,BWX,BWD,BWRCNT,BWLINE,BWDN
+3 QUIT
+4 ;
HDR ; -- 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($PIECE(^DPT(DFN,0),U,3))_" 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 Y=0
SET X=""
FOR
SET Y=$ORDER(^BWP(DFN,2,Y))
IF Y'=+Y
QUIT
SET Z=$PIECE(^BWP(DFN,2,Y,0),U)
IF Z
SET X=X_$PIECE($GET(^BWRACE(Z,0)),U)_" "
+4 SET VALMHDR(3)="Race: "_X
+5 SET VALMHDR(4)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+6 SET VALMHDR(5)=""
+7 SET VALMHDR(6)="# DATE ENTERED INCOME CATEGORY # IN HOUSEHOLD"
+8 QUIT
+9 ;
GETPAT ;
+1 ;W:$D(IOF) @IOF
+2 SET DFN=""
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+4 IF Y<0
QUIT
+5 ;I '$D(^BWP(+Y,0)) W !!,"This patient is not on the Women's Health Register. Cannot update.",! H 2 S DFN="" Q
+6 SET DFN=+Y
+7 QUIT
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=BWLINE
+4 QUIT
+5 ;
GATHER ;
+1 KILL BWCASE
+2 SET BWRCNT=0
SET BWLINE=0
+3 SET BWD=0
FOR
SET BWD=$ORDER(^AUPNINCS("AA",DFN,BWD))
IF BWD'=+BWD
QUIT
Begin DoDot:1
+4 SET BWX=0
FOR
SET BWX=$ORDER(^AUPNINCS("AA",DFN,BWD,BWX))
IF BWX'=+BWX
QUIT
Begin DoDot:2
+5 SET BWY=0
FOR
SET BWY=$ORDER(^AUPNINCS("AA",DFN,BWD,BWX,BWY))
IF BWY'=+BWY
QUIT
Begin DoDot:3
+6 SET BWRCNT=BWRCNT+1
SET BWLINE=BWLINE+1
SET %=^AUPNINCS(BWY,0)
SET Y=BWRCNT
+7 SET $EXTRACT(Y,5)=$$VAL^XBDIQ1(9000026,BWY,.03)
SET $EXTRACT(Y,24)=$$VAL^XBDIQ1(9000026,BWY,.01)
SET $EXTRACT(Y,42)=$$VAL^XBDIQ1(9000026,BWY,.04)
+8 SET BWCASE(BWLINE,0)=Y
SET BWCASE("IDX",BWLINE,BWRCNT)=BWY
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
GETIS ;
+1 WRITE !!
+2 SET BWDN=""
SET DIR(0)="9000026,.01"
SET DIR("A")="Enter INCOME CATEGORY"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET BWDN=Y
+5 QUIT
ADD ;EP called from protocol to open a new case
+1 DO FULL^VALM1
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!!!,"Adding New Income Status Entry for ",$PIECE(^DPT(DFN,0),U),!!
+4 DO GETIS
+5 IF BWDN=""
QUIT
+6 WRITE !,"Adding Income Status..."
KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^AUPNINCS("
SET DLAYGO=9000026
SET DIADD=1
SET X=BWDN
SET DIC("DR")=".02////"_DFN_";.03//"_$$FMTE^XLFDT(DT)_";.04"
+7 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+8 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Adding Income Status entry failed Record failed !! Deleting Record.",!
DO PAUSE
QUIT
+9 SET BWPC=+Y
+10 DO EXIT
+11 QUIT
EDIT ;
+1 SET BWPC=0
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+4 SET BWR1=$ORDER(VALMY(0))
IF 'BWR1
KILL BWR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+5 SET (X,Y)=0
FOR
SET X=$ORDER(BWCASE("IDX",X))
IF X'=+X!(BWPC)
QUIT
IF $ORDER(BWCASE("IDX",X,0))=BWR1
SET Y=$ORDER(BWCASE("IDX",X,0))
SET BWPC=BWCASE("IDX",X,Y)
+6 IF '$DATA(^AUPNINCS(BWPC,0))
WRITE !,"Not a valid INCOME STATUS RECORD."
KILL BWR
DO PAUSE
DO EXIT
QUIT
+7 DO FULL^VALM1
+8 SET DA=BWPC
SET DIE="^AUPNINCS("
SET DR=".01;.03;.04"
DO ^DIE
+9 DO EXIT
+10 QUIT
UR ;EP - called from protocol
+1 IF '$GET(DFN)
WRITE !!,"DFN undefined!"
DO PAUSE
DO EXIT
QUIT
+2 IF $ORDER(^BWP(DFN,2,0))
WRITE !!,"Race values currently entered for this patient:"
+3 SET X=0
FOR
SET X=$ORDER(^BWP(DFN,2,X))
IF X'=+X
QUIT
WRITE !?10
SET Y=$PIECE(^BWP(DFN,2,X,0),U)
IF Y
WRITE $PIECE(^BWRACE(Y,0),U)
+4 DO FULL^VALM1
+5 DO ^XBFMK
+6 SET DIE="^BWP("
SET DA=DFN
SET DR=2
DO ^DIE
+7 DO ^XBFMK
+8 DO EXIT
+9 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL BWX,BWCASE,BWPC,BWR1,BWY
+2 DO TERM^VALM0
+3 SET VALMBCK="R"
+4 DO GATHER
+5 SET VALMCNT=BWLINE
+6 DO HDR
+7 KILL X,Y,Z,I
+8 QUIT
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
EOJ ;
+1 KILL DDSFILE,DIPGM,Y
+2 KILL X,Y,%,DR,DDS,DA,DIC
+3 KILL BWCASE,BWX,BWD,BWRCNT,BWLINE,BWDN
+4 IF $DATA(VALMWD)
DO CLEAR^VALM1
+5 KILL VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
+6 DO KILL^AUPNPAT
+7 QUIT
+8 ;
INCV(V,F) ;EP - patient's income level at date of visit v
+1 IF $GET(F)=""
SET F="I"
+2 IF '$GET(V)
QUIT ""
+3 NEW X,Y,Z,P
+4 IF '$DATA(^AUPNVSIT(V,0))
QUIT ""
+5 SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+6 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+7 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNINCS("AA",P,X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(^AUPNINCS("AA",P,X,Z))
IF Z'=+Z!(Y)
QUIT
Begin DoDot:2
+9 IF (9999999-X)'>D
SET Y=$ORDER(^AUPNINCS("AA",P,X,Z,0))
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 IF Y=""
QUIT ""
+13 QUIT $SELECT(F="I":$$VALI^XBDIQ1(9000026,Y,.01),1:$$VAL^XBDIQ1(9000026,Y,.01))
+14 IF 'P
QUIT ""
INCWH(V,F) ;EP - income stat at procedure date
+1 IF $GET(F)=""
SET F="I"
+2 IF '$GET(V)
QUIT ""
+3 NEW X,Y,Z,P
+4 IF '$DATA(^BWPCD(V,0))
QUIT ""
+5 SET P=$PIECE(^BWPCD(V,0),U,2)
+6 SET D=$PIECE($PIECE(^BWPCD(V,0),U,12),".")
+7 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNINCS("AA",P,X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(^AUPNINCS("AA",P,X,Z))
IF Z'=+Z!(Y)
QUIT
Begin DoDot:2
+9 IF (9999999-X)'>D
SET Y=$ORDER(^AUPNINCS("AA",P,X,Z,0))
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 IF Y=""
QUIT ""
+13 QUIT $SELECT(F="I":$$VALI^XBDIQ1(9000026,Y,.01),1:$$VAL^XBDIQ1(9000026,Y,.01))
+14 IF 'P
QUIT ""
EXPND ; -- expand code
+1 QUIT
+2 ;
