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

BEHOPTC1.m

Go to the documentation of this file. 
  1. BEHOPTC1 ;MSC/IHS/MGH - Patcient Context Object;30-Dec-2010 13:51;PLS
  1.  ;;1.1;BEH COMPONENTS;**004006**;Mar 20, 2007
  1.  ;Copy o DGRPD
  1.  ;ALB/MRL/MLR/JAN/LBD-PATIENT INQUIRY (NEW) ;11-Oct-2010 17:18;DU
  1.  ;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518**;Aug 13, 1993
  1.  ;IHS/ANMC/LJF  3/16/2001 removed limit on # of future appt to display
  1.  ;
  1. SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
  1.  ;
  1. EN ;call to display patient inquiry - input DFN
  1.  ;MPI/PD CHANGE
  1.  S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
  1.  S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
  1.  I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^")
  1.  ;END MPI/PD CHANGE
  1.  K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361,.141 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
  1.  S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'<DT:1,1:0) I DGTMPAD S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
  1.  W ?1,"Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
  1.  S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?10 W:'(I#2) ?51 W DGA(I)
  1.  S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?2,"County: ",DGCC
  1.  S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
  1.  W ?42,"From/To: ",X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPAD
  1.  W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
  1.  W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))
  1.  D CA
  1.  I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")
  1.  I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED")
  1.  I 'DGABBRV W ! D
  1.  .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
  1.  .K ^UTILITY($J,"W")
  1.  .S PTR=0 F  S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR  D
  1.  ..S VAL=+$G(^DPT(DFN,.02,PTR,0))
  1.  ..Q:$$INACTIVE^DGUTL4(VAL,1)
  1.  ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
  1.  ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
  1.  .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
  1.  .K ^UTILITY($J,"W")
  1.  .S PTR=0 F  S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR  D
  1.  ..S VAL=+$G(^DPT(DFN,.06,PTR,0))
  1.  ..Q:$$INACTIVE^DGUTL4(VAL,2)
  1.  ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
  1.  ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
  1.  .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
  1.  .K ^UTILITY($J,"W")
  1.  .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
  1.  .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
  1.  I '$$OKLINE(16) G Q
  1.  S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !!,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
  1.  W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I  I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X
  1.  ;
  1.  ;display the catastrophic disability review date if there is one
  1.  D CATDIS
  1.  ;
  1.  I $G(DGPRFLG)=1 G Q:'$$OKLINE(19) D
  1.  . N DGPDT,DGPTM
  1.  . W !,$$REPEAT^XLFSTR("-",78)
  1.  . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
  1.  . W !,"[PRE-REGISTER DATE:]  "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
  1.  . S DGPTM=$$OUTPTTM^SDUTL3(DFN)
  1.  . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
  1.  . W !,$$REPEAT^XLFSTR("-",78)
  1.  ; Check if patient is an inpatient and on a DOM ward
  1.  ; If inpatient is on a DOM ward, don't display MT or CP messages
  1.  ; If inpatient is NOT on a DOM ward, don't display CP message
  1.  N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
  1.  G Q:'$$OKLINE(14)
  1.  D DOM^DGMTR
  1.  I '$G(DGDOM) D
  1.  .D DIS^DGMTU(DFN)
  1.  .D IN5^VADPT
  1.  .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
  1.  .;IHS/ITSC/WAR 1/9/04 REM'd next line. IHS does not us co-pay enroll
  1.  .;D DIS^EASECU(DFN)   ;Added for LTC III (DG*5.3*518)
  1.  ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
  1.  S VAIP("L")=""
  1.  I $$OKLINE(14) D INP
  1.  I '$G(DGRPOUT),($$OKLINE(17)) D SA
  1.  ;MPI/PD CHANGE
  1. Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q
  1. CA ;Confidential Address
  1.  W !!?1,"Confidential Address:  ",?44,"Confidential Address Categories:"
  1.  N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR
  1.  S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
  1.  I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) D  Q
  1.  .W !?9,"NO CONFIDENTIAL ADDRESS"
  1.  .W !?1,"From/To: NOT APPLICABLE"
  1.  S DGAD=.141,(DGA1,DGA2)=1
  1.  D AL^DGRPU(30)
  1.  D GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")
  1.  ;Format Confidential Address categories
  1.  N DGIEN,DGCAST
  1.  S DGIEN=0
  1.  S DGA2=2
  1.  F  S DGIEN=$O(DGARRAY(2.141,DGIEN)) Q:'DGHIEN  D
  1.  .S DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")
  1.  .S DGCAST=DGARRAY(2.141,DGIEN,1,"E")
  1.  .S DGA(DGA2)=DGA(DGA2)_"("_$S(DGCAST="YES":"Active",1:"Inactive")_")"
  1.  .S DGA2=DGA2+2
  1.  S I=0 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>43) !?9 W:'(I#2) ?44 W DGA(I)
  1.  W !?1,"From/To:  ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")
  1.  Q
  1. HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
  1.  ;MPI/PD CHANGE
  1.  N SSN
  1.  S SSN=$$FMTSSN^BEHOPTCX($P(VADM(2),"^",1))
  1.  W @IOF,!,$P(VADM(1),"^",1),?40,SSN,?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
  1.  ;END MPI/PD CHANGE
  1. INP S VAIP("D")="L" D INP^DGPMV10
  1.  S DGPMT=0
  1.  D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
  1. SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE(17) SAA Q:$G(DGRPOUT)
  1.  Q
  1. SAA ;Scheduled Admit Data
  1.  W !!?14,"Scheduled Admit"
  1.  W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
  1.  W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
  1.  W " on "_$$FMTE^XLFDT(L,"5DZ")
  1.  Q  ;SAA
  1.  ;
  1. CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
  1.  ;
  1. FA G:'$$OKLINE(20) RMK
  1.  S CT=0 W !!,"Future Appointments: " I $O(^DPT(DFN,"S",DT))'>0 W "NONE" G RMK
  1.  W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
  1.  ;F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(FA,0),C=+L I $P(L,"^",2)'["C" D COV D  Q:CT>5  ;IHS/ANMC/LJF 3/16/2001
  1.  F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(FA,0),C=+L I $P(L,"^",2)'["C" D COV D           ;IHS/ANMC/LJF 3/16/2001
  1.  .N DGAPPT
  1.  .S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
  1.  .W !?22,$P(DGAPPT,"@")
  1.  .W ?33,$P(DGAPPT,"@",2)
  1.  .W ?39,$P($S($D(^SC(C,0)):^(0),1:""),"^")," ",COV
  1.  .Q
  1.  I $O(^DPT(DFN,"S",FA))>0 W !,"See Scheduling options for additional appointments."
  1. RMK I '$G(DGRPOUT),($$OKLINE(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10)
  1.  K ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
  1.  Q
  1. COV S COV=$S($P(L,"^",7)=7:" (Collateral) ",1:""),COV=COV_$S($P(L,"^",2)["NT":" * NO ACTION TAKEN *",$P(L,"^",2)["N":" * NO-SHOW *",1:""),CT=CT+1 Q
  1.  Q
  1.  ;
  1. OREN S XQORQUIT=1 Q:'$D(ORVP)  S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
  1.  Q
  1. OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
  1.  ;
  1.  ;IN:   DGLINE --MAX LINE COUNT W/O PAUSE
  1.  ;OUT:  DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
  1.  ;      DGRPOUT[SET]     -- 1 IF "
  1.  N X,Y  ;**286** MLR 09/25/00  Newing X & Y variables prior to ^DIR
  1.  I $G(IOST)["P-" Q DGLINE ; if printer, quit
  1.  I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
  1.  Q DGLINE
  1.  ;
  1. CATDIS ;
  1.  ;displays catastrophic disabity review date if there is one
  1.  N DGCDIS
  1.  I $$GET^DGENCDA(DFN,.DGCDIS) D
  1.  .Q:'DGCDIS("REVDTE")
  1.  .W !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1)
  1.  Q
  1.  ;