- BSDWLE2 ; IHS/OIT/LJF - REMOVE WAIT LIST ENTRY AFTER MAKE APPT
- ;;5.3;PIMS;**1004,1005,1013**;MAY 28, 2004
- ;IHS/OIT/LJF 07/28/2005 PATCH 1004 routine added
- ; 12/29/2005 PATCH 1005 check for being called by event driver while auto-rebooking appt and
- ; printing letters where IO is set to printer; SDMODE not set correctly
- ;
- Q:'$G(DFN) ;bad call from protocol
- Q:$G(SDAMEVT)'=1 ;skip if not make appt event
- Q:$P($G(^DPT(DFN,"S",+$G(SDT),0)),U,7)'=3 ;skip if not scheduled appt
- Q:$G(SDMODE)'=0 ;skip if not in interactive mode
- Q:$E(IOST,1,2)'="C-" ;skip if IO is set to printer;IHS/OIT/LJF 12/29/2005 PATCH 1005
- ;
- NEW PROMPT,BSDR,IEN,X,Y,IENS,ARRAY,DIE,DA,DR,CNT
- Q:'$$ONWL^BSDWLV(DFN,"C") ;not on active waiting list
- D WLDATA^BSDWLV(DFN,"C",.BSDR) ;get list of active entries
- D FULL^VALM1
- ;
- D MSG^BDGF($$REPEAT^XLFSTR("-",10)_"Patient On These Waiting Lists"_$$REPEAT^XLFSTR("-",10),2,0)
- S (CNT,X)=0 F S X=$O(BSDR(X)) Q:'X D ;ihs/cmi/maw added 10/18/2010
- . S BSDY=0 F S BSDY=$O(BSDR(X,BSDY)) Q:'BSDY D
- .. S CNT=CNT+1
- .. D MSG^BDGF(CNT_". "_$P(BSDR(X,BSDY),U,2),1,0)
- ;
- S PROMPT="Do you wish to REMOVE this patient from "_$S($$WLMANY(.BSDR):"one of these waiting lists",1:"this waiting list")
- Q:'$$READ^BDGF("Y",PROMPT)
- ;
- I '$$WLMANY(.BSDR) S IEN=$O(BSDR(0)) ;if only one, don't ask which one
- E D Q:Y<1 ;else, ask which one
- . S (CNT,X)=0 F S X=$O(BSDR(X)) Q:'X S CNT=CNT+1,ARRAY(CNT)=X
- . S Y=$$READ^BDGF("NO^1:"_CNT,"Which One") Q:Y<1
- . S IEN=ARRAY(Y)
- ;
- N BSDSUB ;ihs/cmi/maw added 10/18/2010
- S BSDSUB=$O(BSDR(IEN,0)) ;ihs/cmi/maw added 10/18/2010
- ;S IENS=$P(BSDR(IEN,1),U) ;ihs/cmi/maw added 10/18/2010
- S IENS=$P(BSDR(IEN,BSDSUB),U) ;ihs/cmi/maw added 10/18/2010
- S DA(1)=$P(IENS,",",2),DA=$P(IENS,","),DIE="^BSDWL("_DA(1)_",1,"
- S DR=".07;.08;I $P(^(0),U,11)]"""" S Y=""@1"";.11///`"_DUZ_";@1;1"
- D ^DIE
- Q
- ;
- WLMANY(ARRAY) ; returns one if patient has more than one active waiting list entry
- I $O(ARRAY(+$O(ARRAY(0)))) Q 1
- Q 0
- BSDWLE2 ; IHS/OIT/LJF - REMOVE WAIT LIST ENTRY AFTER MAKE APPT
- +1 ;;5.3;PIMS;**1004,1005,1013**;MAY 28, 2004
- +2 ;IHS/OIT/LJF 07/28/2005 PATCH 1004 routine added
- +3 ; 12/29/2005 PATCH 1005 check for being called by event driver while auto-rebooking appt and
- +4 ; printing letters where IO is set to printer; SDMODE not set correctly
- +5 ;
- +6 ;bad call from protocol
- IF '$GET(DFN)
- QUIT
- +7 ;skip if not make appt event
- IF $GET(SDAMEVT)'=1
- QUIT
- +8 ;skip if not scheduled appt
- IF $PIECE($GET(^DPT(DFN,"S",+$GET(SDT),0)),U,7)'=3
- QUIT
- +9 ;skip if not in interactive mode
- IF $GET(SDMODE)'=0
- QUIT
- +10 ;skip if IO is set to printer;IHS/OIT/LJF 12/29/2005 PATCH 1005
- IF $EXTRACT(IOST,1,2)'="C-"
- QUIT
- +11 ;
- +12 NEW PROMPT,BSDR,IEN,X,Y,IENS,ARRAY,DIE,DA,DR,CNT
- +13 ;not on active waiting list
- IF '$$ONWL^BSDWLV(DFN,"C")
- QUIT
- +14 ;get list of active entries
- DO WLDATA^BSDWLV(DFN,"C",.BSDR)
- +15 DO FULL^VALM1
- +16 ;
- +17 DO MSG^BDGF($$REPEAT^XLFSTR("-",10)_"Patient On These Waiting Lists"_$$REPEAT^XLFSTR("-",10),2,0)
- +18 ;ihs/cmi/maw added 10/18/2010
- SET (CNT,X)=0
- FOR
- SET X=$ORDER(BSDR(X))
- IF 'X
- QUIT
- Begin DoDot:1
- +19 SET BSDY=0
- FOR
- SET BSDY=$ORDER(BSDR(X,BSDY))
- IF 'BSDY
- QUIT
- Begin DoDot:2
- +20 SET CNT=CNT+1
- +21 DO MSG^BDGF(CNT_". "_$PIECE(BSDR(X,BSDY),U,2),1,0)
- End DoDot:2
- End DoDot:1
- +22 ;
- +23 SET PROMPT="Do you wish to REMOVE this patient from "_$SELECT($$WLMANY(.BSDR):"one of these waiting lists",1:"this waiting list")
- +24 IF '$$READ^BDGF("Y",PROMPT)
- QUIT
- +25 ;
- +26 ;if only one, don't ask which one
- IF '$$WLMANY(.BSDR)
- SET IEN=$ORDER(BSDR(0))
- +27 ;else, ask which one
- IF '$TEST
- Begin DoDot:1
- +28 SET (CNT,X)=0
- FOR
- SET X=$ORDER(BSDR(X))
- IF 'X
- QUIT
- SET CNT=CNT+1
- SET ARRAY(CNT)=X
- +29 SET Y=$$READ^BDGF("NO^1:"_CNT,"Which One")
- IF Y<1
- QUIT
- +30 SET IEN=ARRAY(Y)
- End DoDot:1
- IF Y<1
- QUIT
- +31 ;
- +32 ;ihs/cmi/maw added 10/18/2010
- NEW BSDSUB
- +33 ;ihs/cmi/maw added 10/18/2010
- SET BSDSUB=$ORDER(BSDR(IEN,0))
- +34 ;S IENS=$P(BSDR(IEN,1),U) ;ihs/cmi/maw added 10/18/2010
- +35 ;ihs/cmi/maw added 10/18/2010
- SET IENS=$PIECE(BSDR(IEN,BSDSUB),U)
- +36 SET DA(1)=$PIECE(IENS,",",2)
- SET DA=$PIECE(IENS,",")
- SET DIE="^BSDWL("_DA(1)_",1,"
- +37 SET DR=".07;.08;I $P(^(0),U,11)]"""" S Y=""@1"";.11///`"_DUZ_";@1;1"
- +38 DO ^DIE
- +39 QUIT
- +40 ;
- WLMANY(ARRAY) ; returns one if patient has more than one active waiting list entry
- +1 IF $ORDER(ARRAY(+$ORDER(ARRAY(0))))
- QUIT 1
- +2 QUIT 0
