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

IBCNESI2.m

Go to the documentation of this file. 
  1. IBCNESI2 ;ALB/TAZ - MEDICARE PATIENTS WITH SUBSEQUENT INSURANCE ;15 Jan 13
  1.  ;;2.0;INTEGRATED BILLING;**497**;21-MAR-94;Build 120
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  Q  ;Only enter at labels.
  1.  ;
  1. EN(IBRIEN) ; Main Entry Point
  1.  N IBRVST,IBRVIEN
  1.  D EN^VALM("IBCNE MEDICARE COB DISPLAY")
  1. ENQ ;Exit
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. INIT ; Initialize Variables
  1.  S IBRVST="Not Reviewed."
  1.  S IBRVIEN=$$GETREV(IBRIEN)
  1.  D BLD
  1.  Q
  1.  ;
  1. GETREV(IBRIEN) ;Set Review IEN if not already defined.
  1.  N IEN,MSGID
  1.  S IEN=$G(^TMP($J,"IBCNESI2",IBRIEN,"REV IEN"))
  1.  I 'IEN D
  1.  . S MSGID=$$GET1^DIQ(365,IBRIEN_",",.01)
  1.  . S DIC=365.2,DIC(0)="L",DLAYGO=365.2,X=MSGID
  1.  . ; Set Response IEN into .01 field and Not Reviewed in .02 field
  1.  . S DIC("DR")=".01///"_MSGID_";.02///0"
  1.  . D ^DIC
  1.  . S IEN=+Y I IEN>0 S ^TMP($J,"IBCNESI2",IBRIEN,"REV IEN")=IEN
  1.  Q IEN
  1.  ;
  1. BLD ; Build Screen
  1.  N IBLN,IBSTR,IBSTR1,LINEVAR,DIWF,DIWL,DIWR,IBCMDT,IBCMIEN,IBCNT,IBEIEN,IBSEQ,IBURTE,IENS
  1.  K @VALMAR
  1.  S (VALMCNT,IBEIEN)=0
  1.  F  S IBEIEN=$O(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN)) Q:'IBEIEN  D
  1.  . S IBSTR="",IBSTR=$$SETSTR^VALM1(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD"),IBSTR,2,4)
  1.  . S IBSTR=$$SETSTR^VALM1($G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"EMFLAG")),IBSTR,7,7)
  1.  . K IBSTR1 S IBSTR1=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"NAME")) D WRAP(.IBSTR1,70)
  1.  . F IBCNT=1:1:$O(IBSTR1(""),-1) S IBSTR=$$SETSTR^VALM1(IBSTR1(IBCNT),IBSTR,8,78) D SET(IBSTR)
  1.  . S IBSTR=""
  1.  . K IBSTR1 S IBSTR1=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ID QUAL")) I $L(IBSTR1) S IBSTR1=IBSTR1_": "
  1.  . S IBSTR1=IBSTR1_$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ID")) D WRAP(.IBSTR1,70)
  1.  . F IBCNT=1:1:$O(IBSTR1(""),-1) S IBSTR=$$SETSTR^VALM1(IBSTR1(IBCNT),IBSTR,8,78) D SET(IBSTR)
  1.  . S IBSTR1=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ADDRESS 1")) I IBSTR1'="" S IBSTR=$$SETSTR^VALM1(IBSTR1,IBSTR,8,78) D SET(IBSTR)
  1.  . S IBSTR1=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ADDRESS 2")) I IBSTR1'="" S IBSTR=$$SETSTR^VALM1(IBSTR1,IBSTR,8,78) D SET(IBSTR)
  1.  . S IBSTR=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"CITY")) I $L(IBSTR) S IBSTR1=IBSTR_", "
  1.  . S IBSTR=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"STATE")) I $L(IBSTR) S IBSTR1=IBSTR1_IBSTR_" "
  1.  . S IBSTR=$G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ZIP")) I $L(IBSTR) S IBSTR1=IBSTR1_IBSTR,IBSTR=""
  1.  . S IBSTR=$$SETSTR^VALM1(IBSTR1,IBSTR,8,78) D SET(IBSTR)
  1.  . F IBURTE="TE","UR" D
  1.  .. S IBSEQ=0
  1.  .. S IBSEQ=$O(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,IBURTE,IBSEQ)) Q:'IBSEQ  D
  1.  ... K ^UTILITY($J,"W")
  1.  ... K IBSTR1 S IBSTR1=$S(IBURTE="TE":"Phone: ",1:"Website: ")_^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,IBURTE,IBSEQ) D WRAP(.IBSTR1,70)
  1.  ... F IBCNT=1:1:$O(IBSTR1(""),-1) S IBSTR=$$SETSTR^VALM1(IBSTR1(IBCNT),IBSTR,8,78) D SET(IBSTR)
  1.  . S IBSTR=" " D SET(IBSTR)
  1.  S IBSTR=$$SETSTR^VALM1("Comments:",IBSTR,8,78) D SET(IBSTR)
  1.  S IBSTR=" " D SET(IBSTR)
  1.  I '$D(^IBCN(365.2,IBRVIEN,1)) S IBSTR=$$SETSTR^VALM1("No Comments Entered.",IBSTR,8,78) D SET(IBSTR)
  1.  S (IBCNT,IBSEQ)=0
  1.  S IBCMDT=""
  1.  F  S IBCMDT=$O(^IBCN(365.2,IBRVIEN,1,"B",IBCMDT),-1) Q:'IBCMDT  D
  1.  . N IBX
  1.  . S IBCMIEN=$O(^IBCN(365.2,IBRVIEN,1,"B",IBCMDT,"")) I IBCMIEN="" Q
  1.  . S IENS=IBCMIEN_","_IBRVIEN_",",IBSTR=""
  1.  . S IBSTR=$$SETSTR^VALM1($$FMTE^XLFDT($$GET1^DIQ(365.21,IENS,.01),"5Z"),IBSTR,8,38)
  1.  . S IBSTR=$$SETSTR^VALM1("Entered by: "_$$GET1^DIQ(365.21,IENS,.02),IBSTR,40,38)
  1.  . D SET(IBSTR)
  1.  . K ^UTILITY($J,"W")
  1.  . F IBLN=1:1:$P($G(^IBCN(365.2,IBRVIEN,1,IBCMIEN,1,0)),U,3) D
  1.  .. S X=$G(^IBCN(365.2,IBRVIEN,1,IBCMIEN,1,IBLN,0)) S DIWL=1,DIWR=70,DIWF="" D ^DIWP
  1.  . I $D(^UTILITY($J,"W")) S IBLN=0 F  S IBLN=$O(^UTILITY($J,"W",1,IBLN)) Q:'IBLN  D
  1.  .. S IBSTR="",IBSTR=$$SETSTR^VALM1($G(^UTILITY($J,"W",1,IBLN,0)),IBSTR,8,78)
  1.  .. D SET(IBSTR)
  1.  . I $O(^IBCN(365.2,IBRVIEN,1,"B",IBCMDT),-1)'="" D SET(" ")
  1.  Q
  1.  ;
  1. SET(IBX) ; Set up Build Array
  1.  S VALMCNT=VALMCNT+1
  1.  D SET^VALM10(VALMCNT,IBX)
  1.  Q
  1.  ;
  1. WRAP(STR,LEN) ; Wrap Lines
  1.  N PCE,CNT,DATA
  1.  S CNT=1,STR(CNT)=""
  1.  F PCE=1:1:$L(STR," ") D
  1.  . S DATA=$P(STR," ",PCE)
  1.  . I $L(DATA)>LEN F  D  I $L(DATA)<LEN Q
  1.  .. S STR(CNT)=STR(CNT)_$S($L(STR(CNT)):" ",1:"")_$E(DATA,1,LEN),CNT=CNT+1,STR(CNT)="",DATA=" "_$E(DATA,LEN+1,$L(DATA))
  1.  . I $L(STR(CNT))+$S($L(STR(CNT)):1,1:0)+$L(DATA)>LEN S CNT=CNT+1,STR(CNT)=""
  1.  . S STR(CNT)=STR(CNT)_$S($L(STR(CNT)):" ",1:"")_$E(DATA,1,LEN)
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  N IBPNAM,IBRVST
  1.  S IBRVST=$$GET1^DIQ(365.2,IBRVIEN_",",.02) I 
  1.  S IBPNAM=$G(^TMP($J,"IBCNESI2",IBRIEN,"PATIENT NAME"))
  1.  S (VALMHDR(1),VALMHDR(2))=""
  1.  S VALMHDR(2)=$$SETSTR^VALM1("Patient: "_IBPNAM,VALMHDR(2),1,(75-$L(IBRVST)))
  1.  S VALMHDR(2)=$$SETSTR^VALM1(IBRVST,VALMHDR(2),(78-$L(IBRVST)),80)
  1.  S VALM("TITLE")="Medicare Potential COB List",VALMSG="*Exact Match"
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  W @IOF
  1.  W !,"The CODE, if populated, indicates if the insurance is primary, secondary",!,"or tertiary."
  1.  D PAUSE^VALM1
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("IBCNCE",$J)
  1.  D CLEAN^VALM10
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. CMNT ; Enter Comments
  1.  N DA,DD,DIC,DIK,DLAYGO,X,Y
  1.  W !
  1.  ; make sure this entry is not locked already
  1.  L +^IBCN(365.2,IBRVIEN):3 I '$T W !,*7,"Sorry, another user currently editing this entry." D PAUSE^VALM1 G CMNTQ
  1.  S DA(1)=IBRVIEN
  1.  K DO S DIC="^IBCN(365.2,"_DA(1)_",1,",DIC(0)="L",DIC("DR")="1",X=$$NOW^XLFDT,DLAYGO=365.21
  1.  D FILE^DICN
  1.  S DA=+Y I DA>0 D
  1.  . ;Make sure a comment or followup date was created.  Otherwise delete the entry.
  1.  . I '$D(^IBCN(365.2,DA(1),1,DA,1)) S DIK=DIC D ^DIK Q
  1.  . ;There is a comment or follow up date so ask status prompt
  1.  . K DIC
  1.  . D STATUS1
  1.  L -^IBCN(365.2,IBRVIEN)
  1. CMNTQ ;
  1.  S VALMBCK="R"
  1.  D BLD
  1.  Q
  1.  ;
  1. STATUS ; change review status
  1.  L +^IBCN(365.2,IBRVIEN):3 I '$T W !,*7,"Sorry, another user currently editing this entry." D PAUSE^VALM1 G STATUSX
  1.  D STATUS1
  1. STATUSX ;
  1.  ;update list manager display
  1.  L -^IBCN(365.2,IBRVIEN)
  1.  D HDR,BLD
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. STATUS1 ; Entry point from comments section
  1.  N IBSTAT,IBTEXT,DR,DTOUT,DUOUT,DTSS,DFNSS
  1.  ; make sure this entry is not locked already
  1.  ; Prompt for status change
  1.  W !
  1.  S DIR(0)="365.2,.02",DIR("B")="In Process"
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT) G STATUS1X
  1.  M IBSTAT=Y
  1.  I IBSTAT=2 D
  1.  . W !
  1.  . S DIR(0)="Y",DIR("A")="Marking the review complete will remove the entry from the list. Are you sure?",DIR("B")="NO"
  1.  . D ^DIR K DIR
  1.  . I $D(DTOUT)!$D(DUOUT)!'Y S IBSTAT="" Q
  1.  . ; Enter comment for removal from worklist
  1.  . S IBTEXT(1)="Review completed and entry removed from worklist."
  1.  . S DA(1)=IBRVIEN
  1.  . K DO S DIC="^IBCN(365.2,"_DA(1)_",1,",DIC(0)="",X=$$NOW^XLFDT,DLAYGO=365.21
  1.  . D FILE^DICN
  1.  . S DA=+Y I DA'>0 Q
  1.  . D WP^DIE(365.21,DA_","_DA(1)_",",1,,"IBTEXT")
  1.  . K DIC
  1.  I IBSTAT'="" S DIE=365.2,DA=IBRVIEN,DR=".02///"_IBSTAT(0) D ^DIE,CLEAN^DILF S IBRVST=IBSTAT(0) K DIE
  1.  ; need to update the REV STATUS node of the temporary global array
  1.  S DTSS=$P(^TMP($J,"IBCNESI2",IBRIEN,"REV STATUS"),U,2),DFNSS=$P(^TMP($J,"IBCNESI2",IBRIEN,"REV STATUS"),U,3)
  1.  S $P(^TMP($J,"IBCNESI1",DTSS,DFNSS,IBRIEN,"REV STATUS"),U)=IBSTAT  ; update with internal representation of review status
  1. STATUS1X ;
  1.  Q
  1.  ;