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