Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWUINC

BWUINC.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1. EP1(DFN) ;EP - CALLED FROM PROTOCOL
  1.  Q:'$G(DFN)
  1.  Q:'$D(^DPT(DFN))
  1.  Q:$P(^DPT(DFN,0),U,19)
  1.  D EN
  1.  D FULL^VALM1
  1.  K VALMHDR
  1.  Q
  1. EP ;EP CALLED FROM DATA ENTRY
  1.  Q:'$G(BWPAT)
  1.  S DFN=BWPAT
  1.  N BWR
  1.  S Y=BWPAT D ^AUPNPAT
  1.  D EN
  1.  Q
  1. START ;EP - update case data
  1.  K BWCASE,BWX,BWY
  1.  W:$D(IOF) @IOF W !!,"***  Update Patient Income Category Data   ***",!!
  1.  S DFN="" F  D GETPAT Q:DFN=""  D EN,FULL^VALM1,EXIT
  1.  D EOJ
  1.  Q
  1. EN ; -- main entry point for BW UPDATE PATIENT CASE DATA
  1.  D EN^VALM("BW UPDATE INCOME/RACE")
  1.  K BWCASE,BWX,BWD,BWRCNT,BWLINE,BWDN
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$TR($J(" ",80)," ","-")
  1.  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:"????")
  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)_"   "
  1.  S VALMHDR(3)="Race: "_X
  1.  S VALMHDR(4)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(5)=""
  1.  S VALMHDR(6)="#   DATE ENTERED       INCOME CATEGORY   # IN HOUSEHOLD"
  1.  Q
  1.  ;
  1. GETPAT ;
  1.  ;W:$D(IOF) @IOF
  1.  S DFN=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
  1.  I Y<0 Q
  1.  ;I '$D(^BWP(+Y,0)) W !!,"This patient is not on the Women's Health Register.  Cannot update.",! H 2 S DFN="" Q
  1.  S DFN=+Y
  1.  Q
  1. INIT ; -- init variables and list array
  1.  S VALMSG="?? for more actions  + next screen  - prev screen"
  1.  D GATHER ;gather up all records for display
  1.  S VALMCNT=BWLINE
  1.  Q
  1.  ;
  1. GATHER ;
  1.  K BWCASE
  1.  S BWRCNT=0,BWLINE=0
  1.  S BWD=0 F  S BWD=$O(^AUPNINCS("AA",DFN,BWD)) Q:BWD'=+BWD  D
  1.  .S BWX=0 F  S BWX=$O(^AUPNINCS("AA",DFN,BWD,BWX)) Q:BWX'=+BWX  D
  1.  ..S BWY=0 F  S BWY=$O(^AUPNINCS("AA",DFN,BWD,BWX,BWY)) Q:BWY'=+BWY  D
  1.  ...S BWRCNT=BWRCNT+1,BWLINE=BWLINE+1,%=^AUPNINCS(BWY,0),Y=BWRCNT
  1.  ...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)
  1.  ...S BWCASE(BWLINE,0)=Y,BWCASE("IDX",BWLINE,BWRCNT)=BWY
  1.  Q
  1. GETIS ;
  1.  W !!
  1.  S BWDN="",DIR(0)="9000026,.01",DIR("A")="Enter INCOME CATEGORY" KILL DA D ^DIR KILL DIR
  1.  Q:$D(DIRUT)
  1.  S BWDN=Y
  1.  Q
  1. ADD ;EP called from protocol to open a new case
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  W !!!!,"Adding New Income Status Entry for ",$P(^DPT(DFN,0),U),!!
  1.  D GETIS
  1.  Q:BWDN=""
  1.  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"
  1.  D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
  1.  I Y=-1 W !!,$C(7),$C(7),"Adding Income Status entry failed Record failed !!  Deleting Record.",! D PAUSE Q
  1.  S BWPC=+Y
  1.  D EXIT
  1.  Q
  1. EDIT ;
  1.  S BWPC=0
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." G EXIT
  1.  S BWR1=$O(VALMY(0)) I 'BWR1 K BWR1,VALMY,XQORNOD W !,"No record selected." G EXIT
  1.  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)
  1.  I '$D(^AUPNINCS(BWPC,0)) W !,"Not a valid INCOME STATUS RECORD." K BWR D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1.  S DA=BWPC,DIE="^AUPNINCS(",DR=".01;.03;.04" D ^DIE
  1.  D EXIT
  1.  Q
  1. UR ;EP - called from protocol
  1.  I '$G(DFN) W !!,"DFN undefined!" D PAUSE,EXIT Q
  1.  I $O(^BWP(DFN,2,0)) W !!,"Race values currently entered for this patient:"
  1.  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)
  1.  D FULL^VALM1
  1.  D ^XBFMK
  1.  S DIE="^BWP(",DA=DFN,DR=2 D ^DIE
  1.  D ^XBFMK
  1.  D EXIT
  1.  Q
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K BWX,BWCASE,BWPC,BWR1,BWY
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER
  1.  S VALMCNT=BWLINE
  1.  D HDR
  1.  K X,Y,Z,I
  1.  Q
  1. PAUSE ;EP
  1.  S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. EOJ ;
  1.  K DDSFILE,DIPGM,Y
  1.  K X,Y,%,DR,DDS,DA,DIC
  1.  K BWCASE,BWX,BWD,BWRCNT,BWLINE,BWDN
  1.  D:$D(VALMWD) CLEAR^VALM1
  1.  K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
  1.  D KILL^AUPNPAT
  1.  Q
  1.  ;
  1. INCV(V,F) ;EP - patient's income level at date of visit v
  1.  I $G(F)="" S F="I"
  1.  I '$G(V) Q ""
  1.  NEW X,Y,Z,P
  1.  I '$D(^AUPNVSIT(V,0)) Q ""
  1.  S P=$P(^AUPNVSIT(V,0),U,5)
  1.  S D=$P($P(^AUPNVSIT(V,0),U),".")
  1.  S X=0,Y="" F  S X=$O(^AUPNINCS("AA",P,X)) Q:X'=+X!(Y)  D
  1.  .S Z=0 F  S Z=$O(^AUPNINCS("AA",P,X,Z)) Q:Z'=+Z!(Y)  D
  1.  ..I (9999999-X)'>D S Y=$O(^AUPNINCS("AA",P,X,Z,0))
  1.  ..Q
  1.  .Q
  1.  I Y="" Q ""
  1.  Q $S(F="I":$$VALI^XBDIQ1(9000026,Y,.01),1:$$VAL^XBDIQ1(9000026,Y,.01))
  1.  I 'P Q ""
  1. INCWH(V,F) ;EP - income stat at procedure date
  1.  I $G(F)="" S F="I"
  1.  I '$G(V) Q ""
  1.  NEW X,Y,Z,P
  1.  I '$D(^BWPCD(V,0)) Q ""
  1.  S P=$P(^BWPCD(V,0),U,2)
  1.  S D=$P($P(^BWPCD(V,0),U,12),".")
  1.  S X=0,Y="" F  S X=$O(^AUPNINCS("AA",P,X)) Q:X'=+X!(Y)  D
  1.  .S Z=0 F  S Z=$O(^AUPNINCS("AA",P,X,Z)) Q:Z'=+Z!(Y)  D
  1.  ..I (9999999-X)'>D S Y=$O(^AUPNINCS("AA",P,X,Z,0))
  1.  ..Q
  1.  .Q
  1.  I Y="" Q ""
  1.  Q $S(F="I":$$VALI^XBDIQ1(9000026,Y,.01),1:$$VAL^XBDIQ1(9000026,Y,.01))
  1.  I 'P Q ""
  1. EXPND ; -- expand code
  1.  Q
  1.  ;