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