BSDWLE ; IHS/OIT/LJF - WAITING LIST DATA ENTRY
;;5.3;PIMS;**1004,1007,1010,1013**;MAY 28, 2004
;IHS/OIT/LJF 07/21/2005 PATCH 1004 routine added
;
;cmi/anch/maw 2/21/2007 added ability to sort report in SRT, INIT PATCH 1007 item 1007.33
;cmi/anch/maw 10/20/2008 PATCH 1010 RQMT91 added INACT to inactivate a wait list
;cmi/anch/maw 10/20/2008 PATCH 1010 RQMT91 added a check to see if wait list is inactive
;
ASK ; ask user questions
NEW DIC,DLAYGO,Y,BSDWLN,X,BSDSRT
S DIC=9009017.1,DIC(0)="AEMQZ"
I $D(^XUSEC("SDZAC",DUZ)) S DLAYGO=9009017.1,DIC(0)=DIC(0)_"L"
D ^DIC Q:Y<1 S BSDWLN=+Y K DLAYGO,DIC
;cmi/maw 10/20/2008 PATCH 1010 RQMT91 added a check to see if wait list is inactive
I $P($G(^BSDWL(BSDWLN,0)),U,2) D Q
. W !,"Wait List is Inactive"
. H 2
;cmi/maw 10/20/2008 end of mods
D SRT ;cmi/anch/maw 2/21/2007 ask to sort by
;
EN ; -- main entry point for BSDRM WAITING LIST
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSDAM WAITING LIST")
D CLEAR^VALM1
Q
;
SRT ;-- how do they want to sort
S BSDSRT=$$READ^BDGF("S^P:Patient Name;D:Date Added to List;O:Priority;R:Recall Date","Sort By","Patient Name")
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
S X=$$GET1^DIQ(9009017.1,BSDWLN,.01)
S VALMHDR(2)=$$SP(80-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW FILE,IEN,IENS,BSDATA,NAME,BSDCNT,LINE,DFN
S VALMCNT=0 K ^TMP("BSDWLE",$J),^TMP("BSDWLE1",$J)
;
S FILE=9009017.11
S IEN=0 F S IEN=$O(^BSDWL(BSDWLN,1,IEN)) Q:'IEN D
. S IENS=IEN_","_BSDWLN_","
. ;K BSDATA D GETS^DIQ(FILE,IENS,".01;.07","R","BSDATA") ;cmi/anch/maw 2/21/2007 orig line
. K BSDATA D GETS^DIQ(FILE,IENS,".01:.07","R","BSDATA") ;cmi/anch/maw 2/21/2007 mod line PATCH 1007 item 1007.33
. K BSDATAI D GETS^DIQ(FILE,IENS,".01:.07","RI","BSDATAI") ;ihs/cmi/maw 04/15/2011 PATCH 1013
. I BSDATA(FILE,IENS,"DATE REMOVED FROM LIST")]"" Q ;skip if already closed out
. ;cmi/anch/maw 2/21/2007 maw mod/added following 5 lines PATCH 1007 item 1007.33
. ;S ^TMP("BSDWLE1",$J,BSDATA(FILE,IENS,"PATIENT"),IEN)="" ;sort by patient name cmi/anch/maw 2/21/2007 maw orig line PATCH 1007 item 1007.33
. I BSDSRT="P" S ^TMP("BSDWLE1",$J,BSDATA(FILE,IENS,"PATIENT"),IEN)="" ;sort by patient name
. I BSDSRT="D" S ^TMP("BSDWLE1",$J,BSDATA(FILE,IENS,"DATE ADDED TO LIST"),IEN)="" ;sort by date added to list
. I BSDSRT="O" S ^TMP("BSDWLE1",$J,$S(BSDATA(FILE,IENS,"PRIORITY")]"":BSDATA(FILE,IENS,"PRIORITY"),1:"MIDDLE"),IEN)="" ;sort by priority
. I BSDSRT="R" S ^TMP("BSDWLE1",$J,$S(BSDATAI(FILE,IENS,"RECALL DATE","I")]"":BSDATAI(FILE,IENS,"RECALL DATE","I"),1:"0000000"),IEN)="" ;sort by recall date
;
; now take sorted list and build display array
S NAME=0 F S NAME=$O(^TMP("BSDWLE1",$J,NAME)) Q:NAME="" D
. S IEN=0 F S IEN=$O(^TMP("BSDWLE1",$J,NAME,IEN)) Q:'IEN D
. . S IENS=IEN_","_BSDWLN_"," K BSDATA
. . ;D GETS^DIQ(FILE,IENS,".013;.02:.05;.06;1","R","BSDATA") ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.33
. . D GETS^DIQ(FILE,IENS,".01;.013;.02:.05;.06;1","R","BSDATA") ;cmi/anch/maw 2/21/2007 added .01 PATCH 1007 item 1007.33
. . S BSDCNT=$G(BSDCNT)+1 S LINE=$J(BSDCNT,3)_". "
. . ;S LINE=LINE_$$PAD($E(NAME,1,25),28)_BSDATA(FILE,IENS,"HRCN") ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.33
. . S LINE=LINE_$$PAD($E(BSDATA(FILE,IENS,"PATIENT"),1,25),28)_BSDATA(FILE,IENS,"HRCN") ;cmi/anch/maw 2/21/2007 changed patient variable PATCH 1007 item 1007.33
. . S LINE=$$PAD(LINE,41)_BSDATA(FILE,IENS,"DATE ADDED TO LIST")
. . S LINE=$$PAD(LINE,56)_BSDATA(FILE,IENS,"RECALL DATE")
. . S LINE=$$PAD(LINE,71)_BSDATA(FILE,IENS,"PRIORITY")
. . S LINE=$$PAD(LINE,81)_$E(BSDATA(FILE,IENS,"PROVIDER"),1,12)
. . S LINE=$$PAD(LINE,96)_$G(BSDATA(FILE,IENS,"COMMENTS",1))
. . S DFN=$$GET1^DIQ(FILE,IENS,".01","I")
. . D SET(LINE,IEN_U_DFN,BSDCNT,.VALMCNT)
;
I VALMCNT=0 S ^TMP("BSDWLE",$J,1,0)="No Active Patients on this Waiting List",VALMCNT=1
K ^TMP("BSDWLE1",$J)
Q
;
SET(DATA,SAVE,COUNT,LINENUM) ; puts data line into display array
S LINENUM=LINENUM+1 S:COUNT=0 COUNT=1
S ^TMP("BSDWLE",$J,LINENUM,0)=DATA
S ^TMP("BSDWLE",$J,"IDX",LINENUM,COUNT)=SAVE ;=IEN^DFN
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BSDWLE",$J)
Q
;
EXPND ; -- expand code
Q
;
PRINT ;-- print wait list letters
K ^UTILITY($J,"BSDLET")
D MAIN^BSDLTP("W")
Q:'$G(SDLET)
D GETSOME(SDLET)
Q:'$D(^UTILITY($J,"BSDLET",SDLET))
D ZIS^DGUTQ Q:POP
N CNT,REC
S CNT=0
S A=0 F S A=$O(^UTILITY($J,"BSDLET",SDLET,A)) Q:'A D
. U IO
. I CNT>0 W @IOF
. D ^BSDLT
. D RECALL^BSDLT(BSDWLN,A)
. D REST^BSDLT
. S CNT=CNT+1
D ^%ZISC
D RETURN(1)
K ^UTILITY($J,"BSDLET")
Q
;
GETONE ; -- select entry from listing
NEW X,Y,Z
D FULL^VALM1
S BSDN=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
S X=$O(VALMY(0))
S Y=0 F S Y=$O(^TMP("BSDWLE",$J,"IDX",Y)) Q:Y="" Q:BSDN]"" D
. S Z=$O(^TMP("BSDWLE",$J,"IDX",Y,0))
. Q:^TMP("BSDWLE",$J,"IDX",Y,Z)=""
. I Z=X S BSDN=+^TMP("BSDWLE",$J,"IDX",Y,Z)
Q
;
GETSOME(LET) ;-- select multiple entries from the list
NEW X,Y,Z,BSDP,BSDX
D FULL^VALM1
S BSDN=""
D EN^VALM2(XQORNOD(0),"")
I '$D(VALMY) Q
S BSDX=0 F S BSDX=$O(VALMY(BSDX)) Q:'BSDX D
. S Y=0 F S Y=$O(^TMP("BSDWLE",$J,"IDX",Y)) Q:Y="" D
.. S Z=$O(^TMP("BSDWLE",$J,"IDX",Y,0))
.. Q:^TMP("BSDWLE",$J,"IDX",Y,Z)=""
.. I Z=BSDX D
... S BSDN=+^TMP("BSDWLE",$J,"IDX",Y,Z)
... S BSDP=$P(^TMP("BSDWLE",$J,"IDX",Y,Z),U,2)
... S ^UTILITY($J,"BSDLET",LET,BSDP,DT)=""
Q
;
VIEW ;EP; called by BSDWL VIEW protocol
NEW BSDN,DFN
D GETONE I BSDN="" D RETURN(0) Q
S DFN=+$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01,"I") ;line added
D EN^BSDWLV,RETURN(0)
Q
;
RETURN(MODE) ; -- reset variables for return to lt
; MODE=1 to rebuild list
D TERM^VALM0 S VALMBCK="R"
I MODE=1,$G(BSDCLOSE) D HDR^BSDWLE1,INIT^BSDWLE1 Q
I MODE=1 D HDR,INIT
Q
;
ADD ;EP - called by BSDWL ADD protocol
NEW DIC,DD,DO,DA,X,DINUM,Y,DIE,DR,DFN
K DD,DO ;cmi/maw 6/13/2007
D FULL^VALM1
S DFN=+$$READ^BDGF("PO^2:EMQZ","Select Patient") I DFN<1 D RETURN(0) Q
I $$ONNOW(DFN) I '$$READ^BDGF("Y","Patient already on list; Want to add again","NO") D RETURN(0) Q
S DIC="^BSDWL("_BSDWLN_",1,",DIC(0)="AEMQZL"
S DIC("P")=$P(^DD(9009017.1,1,0),U,2)
S DIC("DR")=".03//TODAY;.09;.04///`"_DUZ
S DA(1)=BSDWLN
S X=DFN
D FILE^DICN I Y<1 D PAUSE^BDGF,RETURN(0) Q
S DA=+Y
;
S DIE="^BSDWL("_BSDWLN_",1,",DA(1)=BSDWLN
S DR=".02;.06;.05;1"
D ^DIE,ADDRESS,RETURN(1)
Q
;
EDIT ;EP - called by BSDWL EDIT protocol
NEW BSDN,DIE,DA,DR,Y
D GETONE I BSDN="" D RETURN(0) Q
W !!,$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01) ;display patient name
S DIE="^BSDWL("_BSDWLN_",1,",DA(1)=BSDWLN,DA=BSDN
S DR=".03;.09;.02;.06;.05;1"
D ^DIE,ADDRESS
D RETURN(1)
Q
;
EDITALL ;EP - called by BSDWL EDIT ALL protocol (for closed cases)
NEW BSDN,DIE,DA,DR,Y
D GETONE I BSDN="" D RETURN(0) Q
W !!,$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01) ;display patient name
S DIE="^BSDWL("_BSDWLN_",1,",DA(1)=BSDWLN,DA=BSDN
S DR=".03;.09;.02;.06;.05;1;.07;.08"
D ^DIE
D RETURN(1)
Q
;
REMOVE ;EP - called by BSDWL REMOVE protocol
NEW BSDN,DIE,DA,DR,Y
D GETONE I BSDN="" D RETURN(0) Q
W !!,$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01) ;display patient name
S DIE="^BSDWL("_BSDWLN_",1,",DA(1)=BSDWLN,DA=BSDN
S DR=".07;.08;I $P(^(0),U,11)]"""" S Y=""@1"";.11///`"_DUZ_";@1;1"
D ^DIE,RETURN(1)
Q
;
ADDRESS ; ask to update address & phone number
NEW BSDREG,DFN
S DFN=$$GET1^DIQ(9009017.11,DA_","_DA(1),.01,"I") ;patient IEN
S BSDREG=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.19,"I") ;registration access level
I (BSDREG=1)!(BSDREG=2)!(BSDREG=3&$D(^XUSEC("SDZREGEDIT",DUZ))) D ADDRESS^BSDREG
Q
;
ONNOW(PAT) ; return 1 if patient currently active on list
NEW Y,X,FOUND
S FOUND=0
S Y=0 F S Y=$O(^TMP("BSDWLE",$J,"IDX",Y)) Q:'Y Q:FOUND D
. S Z=0 F S Z=$O(^TMP("BSDWLE",$J,"IDX",Y,Z)) Q:'Z Q:FOUND D
. . I $P(^TMP("BSDWLE",$J,"IDX",Y,Z),U,2)=PAT S FOUND=1
Q FOUND
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
INACT ;-- PATCH 1010 RQMT91 set the wait list to inactive
NEW DIC,DLAYGO,Y,BSDWLN,X,BSDSRT
S DIC=9009017.1,DIC(0)="AEMQZ"
D ^DIC Q:Y<1 S BSDWLN=+Y
S DIE=DIC,DR=.02,DA=BSDWLN
D ^DIE
K DLAYGO,DIC,DA,DR
Q
;
BSDWLE ; IHS/OIT/LJF - WAITING LIST DATA ENTRY
+1 ;;5.3;PIMS;**1004,1007,1010,1013**;MAY 28, 2004
+2 ;IHS/OIT/LJF 07/21/2005 PATCH 1004 routine added
+3 ;
+4 ;cmi/anch/maw 2/21/2007 added ability to sort report in SRT, INIT PATCH 1007 item 1007.33
+5 ;cmi/anch/maw 10/20/2008 PATCH 1010 RQMT91 added INACT to inactivate a wait list
+6 ;cmi/anch/maw 10/20/2008 PATCH 1010 RQMT91 added a check to see if wait list is inactive
+7 ;
ASK ; ask user questions
+1 NEW DIC,DLAYGO,Y,BSDWLN,X,BSDSRT
+2 SET DIC=9009017.1
SET DIC(0)="AEMQZ"
+3 IF $DATA(^XUSEC("SDZAC",DUZ))
SET DLAYGO=9009017.1
SET DIC(0)=DIC(0)_"L"
+4 DO ^DIC
IF Y<1
QUIT
SET BSDWLN=+Y
KILL DLAYGO,DIC
+5 ;cmi/maw 10/20/2008 PATCH 1010 RQMT91 added a check to see if wait list is inactive
+6 IF $PIECE($GET(^BSDWL(BSDWLN,0)),U,2)
Begin DoDot:1
+7 WRITE !,"Wait List is Inactive"
+8 HANG 2
End DoDot:1
QUIT
+9 ;cmi/maw 10/20/2008 end of mods
+10 ;cmi/anch/maw 2/21/2007 ask to sort by
DO SRT
+11 ;
EN ; -- main entry point for BSDRM WAITING LIST
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BSDAM WAITING LIST")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
SRT ;-- how do they want to sort
+1 SET BSDSRT=$$READ^BDGF("S^P:Patient Name;D:Date Added to List;O:Priority;R:Recall Date","Sort By","Patient Name")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+3 SET X=$$GET1^DIQ(9009017.1,BSDWLN,.01)
+4 SET VALMHDR(2)=$$SP(80-$LENGTH(X)\2)_X
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 NEW FILE,IEN,IENS,BSDATA,NAME,BSDCNT,LINE,DFN
+2 SET VALMCNT=0
KILL ^TMP("BSDWLE",$JOB),^TMP("BSDWLE1",$JOB)
+3 ;
+4 SET FILE=9009017.11
+5 SET IEN=0
FOR
SET IEN=$ORDER(^BSDWL(BSDWLN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 SET IENS=IEN_","_BSDWLN_","
+7 ;K BSDATA D GETS^DIQ(FILE,IENS,".01;.07","R","BSDATA") ;cmi/anch/maw 2/21/2007 orig line
+8 ;cmi/anch/maw 2/21/2007 mod line PATCH 1007 item 1007.33
KILL BSDATA
DO GETS^DIQ(FILE,IENS,".01:.07","R","BSDATA")
+9 ;ihs/cmi/maw 04/15/2011 PATCH 1013
KILL BSDATAI
DO GETS^DIQ(FILE,IENS,".01:.07","RI","BSDATAI")
+10 ;skip if already closed out
IF BSDATA(FILE,IENS,"DATE REMOVED FROM LIST")]""
QUIT
+11 ;cmi/anch/maw 2/21/2007 maw mod/added following 5 lines PATCH 1007 item 1007.33
+12 ;S ^TMP("BSDWLE1",$J,BSDATA(FILE,IENS,"PATIENT"),IEN)="" ;sort by patient name cmi/anch/maw 2/21/2007 maw orig line PATCH 1007 item 1007.33
+13 ;sort by patient name
IF BSDSRT="P"
SET ^TMP("BSDWLE1",$JOB,BSDATA(FILE,IENS,"PATIENT"),IEN)=""
+14 ;sort by date added to list
IF BSDSRT="D"
SET ^TMP("BSDWLE1",$JOB,BSDATA(FILE,IENS,"DATE ADDED TO LIST"),IEN)=""
+15 ;sort by priority
IF BSDSRT="O"
SET ^TMP("BSDWLE1",$JOB,$SELECT(BSDATA(FILE,IENS,"PRIORITY")]"":BSDATA(FILE,IENS,"PRIORITY"),1:"MIDDLE"),IEN)=""
+16 ;sort by recall date
IF BSDSRT="R"
SET ^TMP("BSDWLE1",$JOB,$SELECT(BSDATAI(FILE,IENS,"RECALL DATE","I")]"":BSDATAI(FILE,IENS,"RECALL DATE","I"),1:"0000000"),IEN)=""
End DoDot:1
+17 ;
+18 ; now take sorted list and build display array
+19 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BSDWLE1",$JOB,NAME))
IF NAME=""
QUIT
Begin DoDot:1
+20 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BSDWLE1",$JOB,NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+21 SET IENS=IEN_","_BSDWLN_","
KILL BSDATA
+22 ;D GETS^DIQ(FILE,IENS,".013;.02:.05;.06;1","R","BSDATA") ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.33
+23 ;cmi/anch/maw 2/21/2007 added .01 PATCH 1007 item 1007.33
DO GETS^DIQ(FILE,IENS,".01;.013;.02:.05;.06;1","R","BSDATA")
+24 SET BSDCNT=$GET(BSDCNT)+1
SET LINE=$JUSTIFY(BSDCNT,3)_". "
+25 ;S LINE=LINE_$$PAD($E(NAME,1,25),28)_BSDATA(FILE,IENS,"HRCN") ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.33
+26 ;cmi/anch/maw 2/21/2007 changed patient variable PATCH 1007 item 1007.33
SET LINE=LINE_$$PAD($EXTRACT(BSDATA(FILE,IENS,"PATIENT"),1,25),28)_BSDATA(FILE,IENS,"HRCN")
+27 SET LINE=$$PAD(LINE,41)_BSDATA(FILE,IENS,"DATE ADDED TO LIST")
+28 SET LINE=$$PAD(LINE,56)_BSDATA(FILE,IENS,"RECALL DATE")
+29 SET LINE=$$PAD(LINE,71)_BSDATA(FILE,IENS,"PRIORITY")
+30 SET LINE=$$PAD(LINE,81)_$EXTRACT(BSDATA(FILE,IENS,"PROVIDER"),1,12)
+31 SET LINE=$$PAD(LINE,96)_$GET(BSDATA(FILE,IENS,"COMMENTS",1))
+32 SET DFN=$$GET1^DIQ(FILE,IENS,".01","I")
+33 DO SET(LINE,IEN_U_DFN,BSDCNT,.VALMCNT)
End DoDot:2
End DoDot:1
+34 ;
+35 IF VALMCNT=0
SET ^TMP("BSDWLE",$JOB,1,0)="No Active Patients on this Waiting List"
SET VALMCNT=1
+36 KILL ^TMP("BSDWLE1",$JOB)
+37 QUIT
+38 ;
SET(DATA,SAVE,COUNT,LINENUM) ; puts data line into display array
+1 SET LINENUM=LINENUM+1
IF COUNT=0
SET COUNT=1
+2 SET ^TMP("BSDWLE",$JOB,LINENUM,0)=DATA
+3 ;=IEN^DFN
SET ^TMP("BSDWLE",$JOB,"IDX",LINENUM,COUNT)=SAVE
+4 QUIT
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BSDWLE",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PRINT ;-- print wait list letters
+1 KILL ^UTILITY($JOB,"BSDLET")
+2 DO MAIN^BSDLTP("W")
+3 IF '$GET(SDLET)
QUIT
+4 DO GETSOME(SDLET)
+5 IF '$DATA(^UTILITY($JOB,"BSDLET",SDLET))
QUIT
+6 DO ZIS^DGUTQ
IF POP
QUIT
+7 NEW CNT,REC
+8 SET CNT=0
+9 SET A=0
FOR
SET A=$ORDER(^UTILITY($JOB,"BSDLET",SDLET,A))
IF 'A
QUIT
Begin DoDot:1
+10 USE IO
+11 IF CNT>0
WRITE @IOF
+12 DO ^BSDLT
+13 DO RECALL^BSDLT(BSDWLN,A)
+14 DO REST^BSDLT
+15 SET CNT=CNT+1
End DoDot:1
+16 DO ^%ZISC
+17 DO RETURN(1)
+18 KILL ^UTILITY($JOB,"BSDLET")
+19 QUIT
+20 ;
GETONE ; -- select entry from listing
+1 NEW X,Y,Z
+2 DO FULL^VALM1
+3 SET BSDN=""
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 IF '$DATA(VALMY)
QUIT
+6 SET X=$ORDER(VALMY(0))
+7 SET Y=0
FOR
SET Y=$ORDER(^TMP("BSDWLE",$JOB,"IDX",Y))
IF Y=""
QUIT
IF BSDN]""
QUIT
Begin DoDot:1
+8 SET Z=$ORDER(^TMP("BSDWLE",$JOB,"IDX",Y,0))
+9 IF ^TMP("BSDWLE",$JOB,"IDX",Y,Z)=""
QUIT
+10 IF Z=X
SET BSDN=+^TMP("BSDWLE",$JOB,"IDX",Y,Z)
End DoDot:1
+11 QUIT
+12 ;
GETSOME(LET) ;-- select multiple entries from the list
+1 NEW X,Y,Z,BSDP,BSDX
+2 DO FULL^VALM1
+3 SET BSDN=""
+4 DO EN^VALM2(XQORNOD(0),"")
+5 IF '$DATA(VALMY)
QUIT
+6 SET BSDX=0
FOR
SET BSDX=$ORDER(VALMY(BSDX))
IF 'BSDX
QUIT
Begin DoDot:1
+7 SET Y=0
FOR
SET Y=$ORDER(^TMP("BSDWLE",$JOB,"IDX",Y))
IF Y=""
QUIT
Begin DoDot:2
+8 SET Z=$ORDER(^TMP("BSDWLE",$JOB,"IDX",Y,0))
+9 IF ^TMP("BSDWLE",$JOB,"IDX",Y,Z)=""
QUIT
+10 IF Z=BSDX
Begin DoDot:3
+11 SET BSDN=+^TMP("BSDWLE",$JOB,"IDX",Y,Z)
+12 SET BSDP=$PIECE(^TMP("BSDWLE",$JOB,"IDX",Y,Z),U,2)
+13 SET ^UTILITY($JOB,"BSDLET",LET,BSDP,DT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
VIEW ;EP; called by BSDWL VIEW protocol
+1 NEW BSDN,DFN
+2 DO GETONE
IF BSDN=""
DO RETURN(0)
QUIT
+3 ;line added
SET DFN=+$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01,"I")
+4 DO EN^BSDWLV
DO RETURN(0)
+5 QUIT
+6 ;
RETURN(MODE) ; -- reset variables for return to lt
+1 ; MODE=1 to rebuild list
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 IF MODE=1
IF $GET(BSDCLOSE)
DO HDR^BSDWLE1
DO INIT^BSDWLE1
QUIT
+4 IF MODE=1
DO HDR
DO INIT
+5 QUIT
+6 ;
ADD ;EP - called by BSDWL ADD protocol
+1 NEW DIC,DD,DO,DA,X,DINUM,Y,DIE,DR,DFN
+2 ;cmi/maw 6/13/2007
KILL DD,DO
+3 DO FULL^VALM1
+4 SET DFN=+$$READ^BDGF("PO^2:EMQZ","Select Patient")
IF DFN<1
DO RETURN(0)
QUIT
+5 IF $$ONNOW(DFN)
IF '$$READ^BDGF("Y","Patient already on list; Want to add again","NO")
DO RETURN(0)
QUIT
+6 SET DIC="^BSDWL("_BSDWLN_",1,"
SET DIC(0)="AEMQZL"
+7 SET DIC("P")=$PIECE(^DD(9009017.1,1,0),U,2)
+8 SET DIC("DR")=".03//TODAY;.09;.04///`"_DUZ
+9 SET DA(1)=BSDWLN
+10 SET X=DFN
+11 DO FILE^DICN
IF Y<1
DO PAUSE^BDGF
DO RETURN(0)
QUIT
+12 SET DA=+Y
+13 ;
+14 SET DIE="^BSDWL("_BSDWLN_",1,"
SET DA(1)=BSDWLN
+15 SET DR=".02;.06;.05;1"
+16 DO ^DIE
DO ADDRESS
DO RETURN(1)
+17 QUIT
+18 ;
EDIT ;EP - called by BSDWL EDIT protocol
+1 NEW BSDN,DIE,DA,DR,Y
+2 DO GETONE
IF BSDN=""
DO RETURN(0)
QUIT
+3 ;display patient name
WRITE !!,$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01)
+4 SET DIE="^BSDWL("_BSDWLN_",1,"
SET DA(1)=BSDWLN
SET DA=BSDN
+5 SET DR=".03;.09;.02;.06;.05;1"
+6 DO ^DIE
DO ADDRESS
+7 DO RETURN(1)
+8 QUIT
+9 ;
EDITALL ;EP - called by BSDWL EDIT ALL protocol (for closed cases)
+1 NEW BSDN,DIE,DA,DR,Y
+2 DO GETONE
IF BSDN=""
DO RETURN(0)
QUIT
+3 ;display patient name
WRITE !!,$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01)
+4 SET DIE="^BSDWL("_BSDWLN_",1,"
SET DA(1)=BSDWLN
SET DA=BSDN
+5 SET DR=".03;.09;.02;.06;.05;1;.07;.08"
+6 DO ^DIE
+7 DO RETURN(1)
+8 QUIT
+9 ;
REMOVE ;EP - called by BSDWL REMOVE protocol
+1 NEW BSDN,DIE,DA,DR,Y
+2 DO GETONE
IF BSDN=""
DO RETURN(0)
QUIT
+3 ;display patient name
WRITE !!,$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01)
+4 SET DIE="^BSDWL("_BSDWLN_",1,"
SET DA(1)=BSDWLN
SET DA=BSDN
+5 SET DR=".07;.08;I $P(^(0),U,11)]"""" S Y=""@1"";.11///`"_DUZ_";@1;1"
+6 DO ^DIE
DO RETURN(1)
+7 QUIT
+8 ;
ADDRESS ; ask to update address & phone number
+1 NEW BSDREG,DFN
+2 ;patient IEN
SET DFN=$$GET1^DIQ(9009017.11,DA_","_DA(1),.01,"I")
+3 ;registration access level
SET BSDREG=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.19,"I")
+4 IF (BSDREG=1)!(BSDREG=2)!(BSDREG=3&$DATA(^XUSEC("SDZREGEDIT",DUZ)))
DO ADDRESS^BSDREG
+5 QUIT
+6 ;
ONNOW(PAT) ; return 1 if patient currently active on list
+1 NEW Y,X,FOUND
+2 SET FOUND=0
+3 SET Y=0
FOR
SET Y=$ORDER(^TMP("BSDWLE",$JOB,"IDX",Y))
IF 'Y
QUIT
IF FOUND
QUIT
Begin DoDot:1
+4 SET Z=0
FOR
SET Z=$ORDER(^TMP("BSDWLE",$JOB,"IDX",Y,Z))
IF 'Z
QUIT
IF FOUND
QUIT
Begin DoDot:2
+5 IF $PIECE(^TMP("BSDWLE",$JOB,"IDX",Y,Z),U,2)=PAT
SET FOUND=1
End DoDot:2
End DoDot:1
+6 QUIT FOUND
+7 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
INACT ;-- PATCH 1010 RQMT91 set the wait list to inactive
+1 NEW DIC,DLAYGO,Y,BSDWLN,X,BSDSRT
+2 SET DIC=9009017.1
SET DIC(0)="AEMQZ"
+3 DO ^DIC
IF Y<1
QUIT
SET BSDWLN=+Y
+4 SET DIE=DIC
SET DR=.02
SET DA=BSDWLN
+5 DO ^DIE
+6 KILL DLAYGO,DIC,DA,DR
+7 QUIT
+8 ;
