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

BSDWLE.m

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