BSDWLE2.m

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