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

BSDAM.m

Go to the documentation of this file. 
  1. BSDAM ; IHS/ANMC/LJF,WAR - IHS CALLS FOR APPT MGT ;  [ 03/16/2004  10:01 AM ]
  1.  ;;5.3;PIMS;**1004,1005,1006,1007,1011,1012**;MAY 28, 2004
  1.  ;IHS/OIT/LJF 07/28/2005 PATCH 1004 added WLDIS subroutine
  1.  ;            12/30/2005 PATCH 1005 added PTAPPT subroutine; added help text to OIASK
  1.  ;            01/19/2006 PATCH 1005 added code for OTHER REPORTS function under AM
  1.  ;            03/22/2006 PATCH 1005 added PAT subrtn to enter Appt Mgt list template
  1.  ;            07/12/2006 PATCH 1006 changed line label for reprinting PCC+ form
  1.  ;            08/16/2006 PATCH 1006 display warning if patient is ineligible
  1.  ;cmi/anch/maw 2/21/2006 PATCH 1007 checked code in OTHER that calls VENPCC, no changes item 1007.35
  1.  ;cmi/flag/maw 11/9/2009 PATCH 1011 added PWH to other reports
  1.  ;cmi/flag/maw 5/14/2010 PATCH 1012 increased length of OTHER INFO RQMT 129
  1.  ;cmi/flag/maw 06/02/2010 PATCH 1012 RQMT149 added check of appt in OIASK,ADTEST,DELTEST
  1.  ;
  1. PAT(DFN) ;PEP - drop into Appt Management list template with patient defined
  1.  D HDLKILL^SDAMEVT
  1.  NEW SDY,BSDSAV
  1.  S SDY=DFN_";DPT(",BSDSAV=DFN
  1.  D EN1^SDAM,HDLKILL^SDAMEVT
  1.  S DFN=BSDSAV
  1.  NEW X,DIC,Y S X="`"_DFN,DIC=2,DIC(0)="" D ^DIC
  1.  Q
  1.  ;
  1. PTAPPT(DFN) ;EP - display pending appts, last reg update and register membership;IHS/OIT/LJF 12/30/2005 PATCH 1005
  1.  ; called when making an appt (SDAM2 and SDM)
  1.  W !?4,"Age:  "_$$AGE^AUPNPAT(DFN,DT,"R")_"  "_$$PCLINE^SDPPTEM(DFN,DT)
  1.  W !,"Last Registration Update: ",$$LASTREG^BDGF2(DFN)    ;last reg update
  1.  ;
  1.  ;IHS/OIT/LJF 08/16/2006 PATCH 1006 if patient is ineligible, display so
  1.  I $$GET1^DIQ(9000001,DFN,1112)="INELIGIBLE" W !!?8,$$REPEAT^XLFSTR("*",24),!?8,"** INELIGIBLE PATIENT **",!?8,$$REPEAT^XLFSTR("*",24),!
  1.  ;
  1.  D CMS^BSDU1(DFN)                                         ;CMS register membership
  1.  D PEND^BSDU2(DFN,1)                                      ;pending appts
  1.  Q
  1.  ;
  1. WLDIS(DFN) ;EP - display waiting list info on AM screen if by patient ;IHS/OIT/LJF 07/28/2005 PATCH 1004
  1.  ; Called by BLD1^SDAM1
  1.  ;cmi/maw 6/1/2010 PATCH 1012 RQMT149
  1.  NEW BSDWLR D WLDATA^BSDWLV(DFN,"C",.BSDWLR)
  1.  ;
  1.  I '$O(BSDWLR(0)) D SET^SDAM1($$SP(10)_BSDWLR(0)) I 1
  1.  E  D
  1.  . D SET^SDAM1(" ")
  1.  . D SET^SDAM1($$SP(17)_"**** ACTIVE WAIT LIST ENTRIES FOR PATIENT ****")
  1.  . D SET^SDAM1(BSDWLR(0))                   ;caption line
  1.  . D SET^SDAM1($$REPEAT^XLFSTR("-",77))     ;dividing line
  1.  . NEW DATE,LINE,LINEC
  1.  . S DATE=0 F  S DATE=$O(BSDWLR(DATE)) Q:'DATE  D
  1.  . . S LINE=0 F  S LINE=$O(BSDWLR(DATE,LINE)) Q:'LINE  D
  1.  . . . ;D SET^SDAM1($S(LINE=1:"",1:$$SP(3))_$P(BSDWLR(DATE,LINE),U,2))
  1.  . . . S SDACNT=SDACNT+1  ;cmi/maw PATCH 1012
  1.  . . . D SET^SDAM1(SDACNT_" "_$P(BSDWLR(DATE,LINE),U,2))
  1.  . . . S ^TMP("SDAMIDX",$J,SDACNT)=VALMCNT_U_DFN_U_U_U_$S($D(SDDA):SDDA,1:""_U_$P(BSDWLR(DATE,LINE),U))  ;cmi/maw PATCH 1012
  1.  . . . S LINEC=0 F  S LINEC=$O(BSDWLR(DATE,LINE,LINEC)) Q:'LINEC  D
  1.  . . . . D SET^SDAM1($$SP(3)_$P(BSDWLR(DATE,LINE,LINEC),U,2))
  1.  Q
  1.  ;
  1. OIASK ;EP; add/edit other info
  1.  NEW SDW,X,BSDT,BSDC,BSDN,SDERR,BSDPT
  1.  D FULL^VALM1
  1.  ;
  1.  ; select entry from list
  1.  D SEL^SDAMEP Q:'$G(SDW)  Q:SDERR
  1.  S X=^TMP("SDAMIDX",$J,SDW)
  1.  I $P(X,U,6)]"" W !!,*7,">>> This is not a valid appointment." D PAUSE^VALM1 D END Q  ;cmi/maw 6/2/2010 PATCH 1012 for list view
  1.  S BSDPT=$P(X,U,2)
  1.  S BSDT=$P(X,U,3),BSDC=$P(X,U,4),BSDN=$$SCIEN^BSDU2(BSDPT,BSDC,BSDT)
  1.  I 'BSDN D OIASK Q
  1.  S X=$$OI(BSDC,BSDT,BSDN,BSDPT) I X=-1 D OIASK Q
  1.  D END
  1.  Q
  1.  ;
  1. FU ;EP; add follow up appointment
  1.  NEW SDW,X,BSDT,BSDC,BSDN,SDERR,BSDPT
  1.  D FULL^VALM1
  1.  ;
  1.  ; select entry from list
  1.  D SEL^SDAMEP Q:'$G(SDW)  Q:SDERR
  1.  S X=^TMP("SDAMIDX",$J,SDW)
  1.  I $P(X,U,6)]"" W !!,*7,">>> This is not a valid appointment." D PAUSE^VALM1 D END Q  ;cmi/maw 6/2/2010 PATCH 1012 for list view
  1.  S BSDPT=$P(X,U,2)
  1.  ;S BSDT=$P(X,U,3),BSDC=$P(X,U,4),BSDN=$$SCIEN^BSDU2(BSDPT,BSDC,BSDT)
  1.  S BSDT=$P(X,U,3),BSDC=$P(X,U,4),BSDN=$$GETAPT^SDVSIT2(BSDPT,BSDT,BSDC)
  1.  I 'BSDN W !!,*7,">>>A followup appointment cannot be made until after the patient is checked in" D PAUSE^VALM1 D END Q  ;cmi/maw 8/20/2010 PATCH 1012
  1.  N SDCOMKF
  1.  D MC^SDCO5(BSDN,1,.SDCOMKF,.SDCOQUIT) Q:$D(SDCOQUIT)
  1.  K BSDSRFU
  1.  D END
  1.  Q
  1.  ;
  1. OI(BSDC,BSDT,BSDN,DFN) ;EP; called by OI and by SDAMWI1
  1.  ; ask user to update other info
  1.  NEW BSDX,X,LEN,DIR,DA,DR,BSDNEW,BSDOLD
  1.  S BSDX=$G(^SC(BSDC,"S",BSDT,1,BSDN,0)) I +BSDX'=DFN Q 0    ;appt node
  1.  S BSDOLD=$P(BSDX,U,4)
  1.  ;
  1.  ; ask user to update other info
  1.  ;cmi/flag/maw 05/13/2010 PATCH 1012 RQMT129, increased length to 155 characters, the max it can be in that subscript
  1.  ;IHS/OIT/LJF 12/30/2005 PATCH 1005 added help to question
  1.  S X="Enter Reason for Appointment; can be up to 155 characters long (no semi-colons or colons)"
  1.  ;S BSDNEW=$$READ^BDGF("FO^1:150","OTHER INFO",$P(BSDX,U,4))
  1.  S BSDNEW=$$READ^BDGF("FO^1:155","OTHER INFO",$P(BSDX,U,4),X)
  1.  ;
  1.  I BSDNEW[U Q 0
  1.  I (BSDNEW[";")!(BSDNEW[":") D MSG^BDGF("Sorry no semi-colons or colons allowed",2,1) Q -1
  1.  ;
  1.  ; if changed, add to file
  1.  S DIE="^SC("_BSDC_",""S"","_BSDT_",1,",DA=BSDN,DA(1)=BSDT,DA(2)=BSDC
  1.  I BSDNEW="@",BSDOLD]"" S DR="3///@" D ^DIE Q 1
  1.  I BSDOLD=BSDNEW Q 1
  1.  S DR="3///"_BSDNEW D ^DIE
  1.  Q 1
  1.  ;
  1. HS ;EP; print or browse health summary
  1.  D FULL^VALM1,^BSDHSP D ^%ZISC D END Q
  1.  ;
  1. RXPROF ;EP; print med or action profile
  1.  NEW DFN,CLN,TYPE,DIC,X,Y
  1.  D FULL^VALM1
  1.  ;
  1.  ; select patient if not set
  1.  S DFN=$G(SDFN)
  1.  I '$D(SDFN) S DFN=+$$READ^BDGF("P^2:EMQZ","Select Patient")
  1.  Q:DFN<1
  1.  ;
  1.  S TYPE=$$READ^BDGF("S^1:Medication Profile;2:Action Profile","Select Rx Profile to Print") Q:'TYPE
  1.  ; select clinic if not set
  1.  S CLN=$G(SDCLN)
  1.  I '$D(SDCLN),TYPE=2 D  Q:CLN<1       ;only ask if APRO
  1.  . S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: "
  1.  . S DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))"
  1.  . D ^DIC K DIC S CLN=+Y
  1.  ;
  1.  I TYPE=1 D ZIS^BDGF("PQ","MP^BSDFORM("_DFN_")","MED PROFILE","") Q
  1.  I TYPE=2 D ZIS^BDGF("PQ","APRO^BSDFORM("_CLN_","_DFN_","_DT_")","ACTION PROFILE","")
  1.  Q
  1.  ;
  1. TESTS ;EP; append or delete ancillary tests
  1.  D FULL^VALM1
  1.  NEW X,Y
  1.  S X=$$READ^BDGF("SO^A:ADD Ancillary Test;D:DELETE Ancillary Test","Select Action") Q:X=""  Q:X=U
  1.  S Y=$S(X="A":"ADTEST",1:"DELTEST") D @Y
  1.  Q
  1.  ;
  1. ADTEST ; append ancillary test to appt
  1.  NEW SDW,SDERR,SD,SDCL,SDDA,SODT,SDWR,LAB,XRAY,EKG,X
  1.  D SEL^SDAMEP Q:'$G(SDW)  Q:SDERR
  1.  S X=^TMP("SDAMIDX",$J,SDW)
  1.  I $P(X,U,6)]"" W !!,*7,">>> This is not a valid appointment." D PAUSE^VALM1 D END Q  ;cmi/maw 6/2/2010 PATCH 1012 for list view
  1.  S DFN=$P(X,U,2)
  1.  S SD=$P(X,U,3),SDCL=$P(X,U,4),SDDA=$$SCIEN^BSDU2(DFN,SDCL,SD)
  1.  S Y=SD D DTS^SDUTL S SODT=Y,SDWR=0,(LAB,XRAY,EKG)=""
  1.  I $$CO^BSDU2(DFN,SDCL,SD,SDDA) D  Q
  1.  . W !?5,"** Appointment already checked out; cannot add test. **"
  1.  . D PAUSE^BDGF,END
  1.  D DISPTEST(DFN,SD)   ;displays any already scheduled
  1.  D ORD^SDM3,END
  1.  Q
  1.  ;
  1. DELTEST ; delete ancillary test from appt
  1.  NEW SDW,SDERR,SD,SDCL,SDDA,X,BSDRR,DIR,DR,DA,DIE,Y,BSDX
  1.  D SEL^SDAMEP Q:'$G(SDW)  Q:SDERR
  1.  S X=^TMP("SDAMIDX",$J,SDW)
  1.  I $P(X,U,6)]"" W !!,*7,">>> This is not a valid appointment." D PAUSE^VALM1 D END Q  ;cmi/maw 6/2/2010 PATCH 1012 for list view
  1.  S SD=$P(X,U,3),SDCL=$P(X,U,4),DFN=$P(X,U,2),SDDA=$$SCIEN^BSDU2(DFN,SDCL,SD)
  1.  ;
  1.  I $$CO^BSDU2(DFN,SDCL,SD,SDDA) D  D END Q
  1.  . W !?5,"** Appointment already checked out; cannot delete test. **"
  1.  . D PAUSE^BDGF
  1.  ;
  1.  D DISPTEST(DFN,SD,1)   ;displays any already scheduled
  1.  ;
  1.  I '$D(BSDRR) D  D END  Q
  1.  . W !,"** No tests scheduled; nothing to delete. **"
  1.  . D PAUSE^BDGF
  1.  ;
  1.  S BSDX=$O(BSDRR(""),-1) I 'X D END Q
  1.  K DIR S DIR(0)="NO^1",DIR("A")="Select Test to Delete" D ^DIR
  1.  Q:Y<1  Q:Y>BSDX  K DIR
  1.  S DR=(BSDRR(Y)+2)_"///@",DA=SD,DA(1)=DFN,DIE="^DPT("_DFN_",""S"","
  1.  D ^DIE
  1.  ;
  1.  D END
  1.  Q
  1.  ;
  1. END ; end of action; return to appt mgt menu      
  1.  D BLD^SDAM
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. DISPTEST(PAT,DATE,SAVE) ; -- displays any ancillary tests already scheduled
  1.  NEW DATA,LINE,I,CNT
  1.  S DATA=$G(^DPT(DFN,"S",SD,0)) Q:'DATA
  1.  F I=3,4,5 D           ;loop thru tests
  1.  . Q:$P(DATA,U,I)=""   ;nothing scheduled for that test
  1.  . S CNT=$G(CNT)+1,LINE(CNT,"F")="!?5"
  1.  . S LINE(CNT)=$$TST(I)_" scheduled for "_$$FMTE^XLFDT($P(DATA,U,I))
  1.  . ;
  1.  . ; if need to select by line number, save test number
  1.  . I $G(SAVE) S BSDRR(CNT)=I,LINE(CNT)=$J(CNT,2)_". "_LINE(CNT)
  1.  D EN^DDIOL(.LINE)
  1.  Q
  1.  ;
  1. TST(NUMBER) ; -- returns name of test by number
  1.  Q $S(NUMBER=3:"LAB",NUMBER=4:"X-RAY",1:"EKG")
  1.  ;
  1.  ;IHS/OIT/LJF 01/19/2006 PATCH 1005 new code begins
  1.  ;cmi/anch/maw 2/21/2006 PATCH 1007 checked code that calls VENPCC, no changes
  1. OTHER ;EP; called by BSDAM OTHER REPORTS protocol
  1.  ; if in Clinic Mode, ask for Patient
  1.  D FULL^VALM1
  1.  I SDAMTYP="C" NEW DFN,SDFN D  Q:$G(DFN)<1
  1.  . D SEL^VALM2 I $O(VALMY(0)) S (DFN,SDFN)=$P(^TMP("SDAMIDX",$J,$O(VALMY(0))),U,2)
  1.  . I $G(DFN) NEW VADM,VA D DEM^VADPT,MSG^BDGF($$SP(5)_VADM(1)_$$SP(6)_"#"_VA("BID"),1,1)
  1.  ;
  1.  ; ask user to select report(s) to print
  1.  NEW BSDRPT,BSDA,X,Y,BSDXXX
  1.  ;F X=1:1:7 S BSDA(X)=$J(X,3)_". "_$P($T(RPT+X),";;",2)  cmi/maw 11/09/2009 PATCH 1011 orig line
  1.  ;F X=1:1:8 S BSDA(X)=$J(X,3)_". "_$P($T(RPT+X),";;",2)  ;cmi/maw 11/09/2009 PATCH 1011 added PWH
  1.  F X=1:1:9 S BSDA(X)=$J(X,3)_". "_$P($T(RPT+X),";;",2)  ;cmi/maw 05/14/2010 PATCH 1012 added AIU
  1.  ;S Y=$$READ^BDGF("LO^1:7","Choose Report(s) To Print","","","",.BSDA) Q:'Y  ;cmi/maw 11/09/2009 PATCH 1011 orig line
  1.  ;S Y=$$READ^BDGF("LO^1:8","Choose Report(s) To Print","","","",.BSDA) Q:'Y  ;cmi/maw 11/09/2009 PATCH 1011 added PWH
  1.  S Y=$$READ^BDGF("LO^1:9","Choose Report(s) To Print","","","",.BSDA) Q:'Y  ;cmi/maw 05/14/2010 PATCH 1012 added AIU
  1.  ;
  1.  S BSDXXX=Y F  S BSDRPT=$P($T(RPT+BSDXXX),";;",3) Q:BSDRPT=""  D
  1.  . ;
  1.  . I '$$AVAIL(+BSDXXX) D  Q        ;report not available to this user or this facility
  1.  . . D MSG^BDGF("Sorry, you do not have access to print "_$P($T(RPT+BSDXXX),";;",2),1,1)
  1.  . . D PAUSE^BDGF
  1.  . . S BSDXXX=$P(BSDXXX,",",2,99)  ;reset list to reports not yet printed
  1.  . ;
  1.  . D MSG^BDGF($P($T(RPT+BSDXXX),";;",2),2,1)
  1.  . S BSDXXX=$P(BSDXXX,",",2,99)  ;reset list to reports not yet printed
  1.  . D @BSDRPT D ^%ZISC            ;print report
  1.  ;
  1.  I SDAMTYP="P",$G(DFN) D SETPT(DFN)   ;make sure all current patient variables set correctly
  1.  I SDAMTYP="C" D KILL^AUPNPAT         ;make sure all patient variables are gone if in clinic mode
  1.  Q
  1.  ;
  1. AVAIL(N) ; returns 1 if user has access to print report N
  1.  NEW CODE
  1.  S CODE=$P($T(RPT+N),";;",4) I CODE="" Q 1
  1.  X CODE     ;returns Y set to 1 or 0
  1.  Q Y
  1.  ;
  1. VST ; view pcc visits
  1.  NEW BSDSAV
  1.  S (BSDSAV,APCDPAT)=DFN D GETVISIT^APCDDISP
  1.  I APCDVSIT="" W !!,"No VISIT selected!" D PAUSE^BDGF Q
  1.  D ^APCDVD,EOJ^APCDDISP
  1.  S (DFN,AUPNPAT)=BSDSAV D SETPT(DFN)
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. SETPT(DFN) ;sets AUPN variables when DFN is set
  1.  NEW X,DIC,Y S X="`"_DFN,DIC=2,DIC(0)="" D ^DIC Q
  1.  ;IHS/OIT/LJF 01/19/2006 PATCH 1005 new code ends
  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.  ;IHS/OIT/LJF 07/12/2006 PATCH 1006 changed line label for PCC+ form
  1. RPT ;;IHS/OIT/LJF 01/19/2006 PATCH 1005 added lines below
  1.  ;;Routing Slip;;WISD^BSDROUT(+$G(DFN),DT,"RS","",1);;
  1.  ;;Face Sheet;;DFN^AGFACE;;
  1.  ;;Rx Profiles;;RXPROF^BSDAM;;S Y=$S('$D(^XUSEC("DGZNOCLN",DUZ)):1,1:0);;
  1.  ;;PCC+ Form;;PIMS^VENPCC(+$G(DFN));;S Y=$S($L($T(PIMS^VENPCC))=0:0,'$D(^XUSEC("VENZPRINT",DUZ)):0,1:1);;
  1.  ;;Visit Display;;VST^BSDAM;;
  1.  ;;Chart Locator;;PAT^BSDCF;;
  1.  ;;CWAD Notes;;CWAD^TIULX;;S Y=$S($L($T(CWAD^TIULX))=0:0,'$D(^XUSEC("TIUZCWAD",DUZ)):0,1:1);;
  1.  ;;Patient Wellness Handout;;PWH^BSDROUT("OR",DFN,DT);;
  1.  ;;Address/Insurance Update;;OR^BSDAIU;;