MBAARPC1 ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
;;1.0;Scheduling Calendar View;**1**;FEB 10, 2016;Build 85
;
;This routine has multiple RPCs created to support the mobile Scheduling apps
;Associated ICRs:
; ICR#
; 6053 DPT
; 6044 SC(
; 4433 SDAMA301
; 6417 DATP^SDWLEVAL
; 6418 $$CHKENC^SDWLQSC1
;
GETPEND(RV,DFN,DT) ; Get pending appointments for a patient MBAA RPC: MBAA PATIENT PENDING APPT
; input is patient dfn and the date to start the search and go forward
K RETURN
I $G(DFN)="" S RV(0)="1^DFN must be defined" Q
I $G(DT)="" S RV(0)="1^Start date must be defined" Q
N CNT,SCAP,APP,CLN,%
S CNT=""
D GETPND(.APP,DFN,DT)
F S CNT=$O(APP(CNT)) Q:CNT="" D
. S RETURN(CNT,"COLLATERAL VISIT")=$G(APP(CNT,13))
. S RETURN(CNT,"APPOINTMENT TYPE")=$$APTYNAME^MBAAMDA2($G(APP(CNT,9.5)))
. S RETURN(CNT,"LAB")=$G(APP(CNT,2))
. S RETURN(CNT,"XRAY")=$G(APP(CNT,3))
. S RETURN(CNT,"EKG")=$G(APP(CNT,4))
. S %=$$GETCLN^MBAAMAP1(.CLN,$G(APP(CNT,.01)))
. S RETURN(CNT,"CLINIC")=$P($G(CLN("NAME")),U,2)
. N SCAP S %=$$GETSCAP(.SCAP,$G(APP(CNT,.01)),DFN,CNT)
. S RETURN(CNT,"LENGTH OF APP'T")=$G(SCAP("LENGTH"))
. S RETURN(CNT,"CONSULT LINK")=$G(SCAP("CONSULT"))
. S RETURN(CNT,"OTHER")=$G(SCAP("OTHER"))
.; Adding new fields
. S RETURN(CNT,"CLINIC ID")=$G(APP(CNT,.01))
. S RETURN(CNT,"CURRENT STATUS")=$G(APP(CNT,100))
. S RETURN(CNT,"DESIRED APPT DATE")=$G(APP(CNT,127))
S RETURN=($D(RETURN)>0)
D MERGE^MBAAMRPC(.RV,.RETURN)
Q 1
;
GETPND(LST,PAT,SD1) ; Get pending appointments MBAA RPC: MBAA PATIENT PENDING APPT
N SDT1
S SDT1=$$FMADD^XLFDT(SD1,0,0,-1,0)
F S SDT1=$O(^DPT(PAT,"S",SDT1)) Q:SDT1=""!(SDT1'>0) D ;ICR#: 6053 DPT
. Q:$G(SDT1)=""
. N ERR,ARRAY,IENS S IENS=SDT1_","_$G(PAT)_"," D GETS^DIQ(2.98,IENS,".01;13;9.5;5;6;7;3;27","I","ARRAY","ERR")
. Q:$G(ARRAY(2.98,IENS,.01,"I"))=""
. Q:$G(ERR)
. S LST(SDT1,.01)=$G(ARRAY(2.98,IENS,.01,"I"))
. S LST(SDT1,13)=$G(ARRAY(2.98,IENS,13,"I"))
. S LST(SDT1,9.5)=$G(ARRAY(2.98,IENS,9.5,"I"))
. S LST(SDT1,2)=$G(ARRAY(2.98,IENS,5,"I"))
. S LST(SDT1,3)=$G(ARRAY(2.98,IENS,6,"I"))
. S LST(SDT1,4)=$G(ARRAY(2.98,IENS,7,"I"))
. S LST(SDT1,5)=$G(ARRAY(2.98,IENS,6,"I"))
. S LST(SDT1,10)=$G(ARRAY(2.98,IENS,3,"I"))
. S LST(SDT1,127)=$G(ARRAY(2.98,IENS,27,"I"))
. N R1 D STATUS(.R1,PAT,SDT1,$G(ARRAY(2.98,IENS,.01,"I"))) I $G(R1)'="" S LST(SDT1,100)=$P(R1,";",3)
. K ARRAY,ERR,IENS
;. ;S RETURN(Y,100)=$P($$STATUS^SDAM1(PAT,Y,+AP,AP),";",3) ;ICR#: 2851 MBAA ACCESS TO SDAM1 API get appointment status
;. ;I $P($G(^DPT(PAT,"S",Y,1)),"^")'="" S RETURN(Y,127)=$P($G(^DPT(PAT,"S",Y,1)),"^")
Q
GETSCAP(RETURN,SC,DFN,SD) ; Get clinic appointment MBAA RPC: MBAA PATIENT PENDING APPT
N NOD0,CO,TXT
I '$D(DFN)!(+$G(DFN)'>0) S RETURN=0,TXT(1)="DFN" D ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
I '$D(SC)!(+$G(SC)'>0) S RETURN=0,TXT(1)="SC" D ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
I '$D(SD)!(+$G(SD)'>0) S RETURN=0,TXT(1)="SD" D ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
D GETSCAP^MBAAMDA1(.RETURN,+SC,+DFN,+SD)
I $D(RETURN) D
. S NOD0=RETURN(0),CO=$G(RETURN("C"))
. S RETURN("IFN")=RETURN
. S RETURN("USER")=$P(NOD0,U,6)
. S RETURN("DATE")=$P(NOD0,U,7)
. S RETURN("CHECKOUT")=$P(CO,U,3)
. S RETURN("CHECKIN")=$P(CO,U,1)
. S RETURN("LENGTH")=$P(NOD0,U,2)
. S RETURN("CONSULT")=$P($G(RETURN("CONS")),U)
. S RETURN("OTHER")=$P($G(NOD0),"^",4)
Q 1
;
PROVCLIN(RESULTS,PROVIDER) ; Get list of clinics for a provider MBAA RPC: MBAA PROVIDER TO CLINIC
; input is provider id (IEN for VA(200))
K RESULTS
I $G(PROVIDER)="" S RESULTS(0)="1^Provider IEN is required." Q
S (CNT,CLIN)=0 F S CLIN=$O(^SC(CLIN)) Q:CLIN'>0 S PROV=0 F S PROV=$O(^SC(CLIN,"PR","B",PROV)) Q:PROV'>0 S REC=0 F S REC=$O(^SC(CLIN,"PR","B",PROV,REC)) Q:REC'>0 D ;ICR#: 6044 SC(
.;T13 Change to use FM
.N ARRAY D GETS^DIQ(44,CLIN_",",".01;2","I","ARRAY")
.S CLINNAME=$G(ARRAY(44,CLIN_",",.01,"I"))
.S TYPE=$G(ARRAY(44,CLIN_",",2,"I"))
.Q:$G(TYPE)'="C"
.;Q:$P(^SC(CLIN,0),"^",3)'="C" ;ICR#: 6044 SC(
.;N IENS S IENS=$G(REC)_","_$G(CLIN)_"," S PROVIDER=$$GET1^DIQ(44.1,IENS,".01","I")
.;Q:$P(^SC(CLIN,0),"^",3)'="C" ;ICR#: 6044 SC(
.Q:$G(PROV)'=$G(PROVIDER)
.;S CLINNAME=$P(^SC(CLIN,0),"^") ;ICR#: 6044 SC(
.S RESULTS(CNT)=CLIN_"^"_CLINNAME,CNT=CNT+1
.K CLINNAME,TYPE
K CLIN,PROV,PROVIDER,CNT,REC,TYPE
S:$G(RESULTS(0))="" RESULTS(0)="1^Provider is not assigned to any clinics."
Q
;Line tags REMREC, UPDTEWL, PARSE, UPDATE have been commented out due to being descoped from the first release
;REMREC(RESULTS,DFN,CLINIC,PROVIDER,RECALLDT,PTRECDT) ; Remove a patient from the Recall list MBAA RPC: MBAA REMOVE FROM RECALL LIST
; Input Parameters:
; DFN = Patient ID
; Clinic = Clinic ID - IEN from the Hospital Location file (#44)
; PROVIDER = Provider IEN (optional)
; RECALLDT = The recall date requested by the provider
; PTRECDT = The recall date requested by the patient
; Either the RECALLDT or the PTRECDT is required.
;
; Checks for multiple entries on the recall list that are for the same patient, provider, clinic and recall dates and deletes all
; Output:
; If successful:
; RESULTS="1^DELETED" the patient was removed from the recall list for the clinic
; If not successful:
; RESULTS="0^DFN MISSING"
; RESULTS="0^CLINIC ID MISSING"
; RESULTS="0^User doesn't have the provider key."
;
;S RESULTS(0)=""
;I $G(DFN)="" S RESULTS(0)="0^DFN MISSING" Q
;I $G(CLINIC)="" S RESULTS(0)="0^CLINIC ID MISSING" Q
;T13 Changes to use FM
;N JX S JX=$$GET1^DIQ(2,$G(DFN),.01) I $G(JX)="" S RESULTS(0)="0^NOT A PATIENT" Q ;ICR#: 6053 DPT
;N JX S JX=$$GET1^DIQ(44,$G(CLINIC),.01) I $G(JX)="" S RESULTS(0)="0^NOT A CLINIC" Q ;ICR#: 6044 SC(
;I '$D(^DPT(DFN,0)) S RESULTS(0)="0^NOT A PATIENT" Q ;ICR#: 6053 DPT
;I '$D(^SC(CLINIC,0)) S RESULTS(0)="0^NOT A CLINIC" Q ;ICR#: 6044 SC(
;T13 Change to use FM
;S (SDPRV,KEY,SDFLAG)="" S SDPRV=$P($G(^SD(403.5,CLINIC,0)),U,5) I SDPRV'="" S KEY=$P($G(^SD(403.54,SDPRV,0)),U,7) D ;ICR#: 6045 SD(403.5
;N CLIN S CLIN=$O(^SD(403.5,"E",CLINIC,0))
;I $G(CLIN)>0 S (SDPRV,KEY,SDFLAG)="" S SDPRV=$$GET1^DIQ(403.5,CLIN_",",4,"I") I SDPRV'="" S KEY=$$GET1^DIQ(403.54,SDPRV_",",6,"I") D ;ICR#: 6158 SD(403.54
;.Q:KEY=""
;.N VALUE
;.S VALUE=$$LKUP^XPDKEY(KEY) K KY D OWNSKEY^XUSRB(.KY,VALUE,DUZ) ;ICR#: 3277 XUSRB
;.I $G(KY(0))=0 S RESULTS(0)="0^User doesn't have the security key."
;Q:$G(RESULTS(0))'=""
;S IEN=0 F S IEN=$O(^SD(403.5,"E",CLINIC,IEN)) Q:IEN'>0 D ;ICR#: 6045 SD(403.5
;.K NODE,PROV,PROVDT,PTDT,RESULTS(0),XDFN,OK
;.S OK=0
;.;T13 Change to use FM
;.;S NODE=$G(^SD(403.5,IEN,0)) ;ICR#: 6045 SD(403.5
;.;S XDFN=$P(NODE,"^")
;.N ARRAY,ERR D GETS^DIQ(403.5,IEN_",",".01;4;5;5.5","I","ARRAY","ERR")
;.S XDFN=$G(ARRAY(403.5,IEN_",",.01,"I")),PROV=$G(ARRAY(403.5,IEN_",",4,"I")),PROVDT=$G(ARRAY(403.5,IEN_",",5,"I")),PTDT=$G(ARRAY(403.5,IEN_",",5.5,"I"))
;.I $G(XDFN)'=DFN S RESULTS(0)="0^PATIENT NOT ON RECALL LIST" Q
;.;S PROV=$P(NODE,"^",5),PROVDT=$P(NODE,"^",6),PTDT=$P(NODE,"^",12),DFN1=$P(NODE,"^",1)
;.;I $G(PROV)'=$G(PROVIDER) Q ;S RESULTS(0)="0^PROVIDER DOESN'T MATCH" Q
;.;I $G(PROVDT)'=$G(RECALLDT) Q ;S RESULTS(0)="0^PROVIDER RECALL DATE DOESN'T MATCH" Q
;.;I $G(PTRECDT)'="" I $G(PTDT)'=$G(PTRECDT) S RESULTS(0)="0^PATIENT RECALL DATE DOESN'T MATCH" Q
;.;I $G(DFN1)'=$G(DFN) S RESULTS(0)="0^PATIENT MISMATCH" Q
;.S DIK="^SD(403.5,",DA=IEN D ^DIK ;ICR#: 6045 SD(403.5
;.S OK=1
;I OK=1 S RESULTS(0)="1^DELETED"
;I OK=0 S RESULTS(0)="0^NOT ON RECALL LIST"
;K SDPRV,KEY,SDFLAG,VALUE,IEN,DIK,DA,OK
;Q
UPDTEWL(RESULTS,DFN,SDWLIEN,SDWLDISP,SDWLDATA) ; Update or remove a patient on the EWL MBAA RPC: MBAA REMOVE FROM EWL
;Input paramters:
; DFN - Patient DFN
; EWLIEN - for EWL Record to be updated
; DISP - The disposition code of the EWL entry:
; D:DEATH;NC:REMOVED/NON-VA CARE;SA:REMOVED/SCHEDULED-ASSIGNED;CC:REMOVED/VA CONTRACT CARE;NN:REMOVED/NO LONGER NECESSARY;ER:ENTERED IN ERROR;CL:CLINIC CHANGE
; SDWLDATA array:
; $P(1) = SDWLAPPT(1)=SCHEDULED DATE OF APPT
; $P(2) = SDWLAPPT(2)=PTR TO APPT CLINIC (CLINIC WHERE APPT MADE)
; $P(4) = SDWLAPPT(15)=APPOINTMENT INSTITUTION (PTR to Institution File)
; $P(5) = SDWLAPPT(13)=APPT STOP CODE (PTR to file 40.7)
; $P(6) = SDWLAPPT(14)=APPT CREDIT STOP CODE (PTR to file 40.7)
; $P(7) = SDWLAPPT(16)=APPT STATION NUMBER (Free Text) MUST BE AN IEN FROM DIC(4 but is not a ptr field)
; $P(3) = SDWLAPPT(3)=APPT STATUS (Set of codes: 'R' FOR Scheduled/Kept;
; 'I' FOR Inpatient;
; 'NS' FOR No-Show;
; 'NSR' FOR No_Show, Rescheduled;
; 'CP' FOR Canceled by Patient;
; 'CPR' FOR Canceled by Patient, Rescheduled;
; 'CC' FOR Canceled by Clinic;
; 'CCR' FOR Canceled by Clinic, Rescheduled;
; 'NT' FOR No Action Taken; )
;Output:
; RESULTS(0)=1 - Successful
; RESULTS(0)="0^DFN is required" - DFN parameter missing
; RESULTS(0)="0^SDWLIEN is required" - SDWLIEN parameter is missing
; RESULTS(0)="0^Patient not on EWL" - Patient is not on the EWL
; RESULTS(0)="0^Disposition is missing."
; RESULTS(0)="0^Disposition is SA but missing Appointment data."
;
S RESULTS(0)=1
I $G(DFN)="" S RESULTS(0)="0^DFN is required" Q
I $G(SDWLIEN)="" S RESULTS(0)="0^SDWLIEN is required" Q
I '$D(^SDWL(409.3,"B",DFN)) S RESULTS(0)="0^Patient not on EWL" Q ;ICR#: 6046 SDWL(409.3
I $G(SDWLDISP)="" S RESULTS(0)="0^Disposition is missing." Q
I ($G(SDWLDISP)="SA"&($G(SDWLDATA)="")) S RESULTS(0)="0^Disposition is SA but missing Appointment data." Q
;T13 Change to use FM
N TYPE S TYPE=$$GET1^DIQ(409.3,SDWLIEN_",",23,"I") I $G(TYPE)="C" S RESULTS(0)="0^Patient not on EWL" Q ;ICR#: 6046 SDWL(409.3
I $P(^SDWL(409.3,SDWLIEN,0),"^",17)="C" S RESULTS(0)="0^Patient not on EWL" Q ;ICR#: 6046 SDWL(409.3
D PARSE
I '$$LOCK^MBAAWLAP(.SDWLERR,SDWLIEN) ; W !,"Another User is Editing this Entry. Try Later." Q
S %=$$DETAIL^MBAAWLAP(.SDWLDATA,SDWLIEN)
G ENQ:SDWLDISP=""
D UPDATE(DFN,SDWLIEN,SDWLDISP,.SDWLDATA)
ENQ ; MBAA RPC: MBAA REMOVE FROM EWL
S %=$$UNLOCK^MBAAWLAP(SDWLIEN)
Q
UPDATE(SDWLDFN,SDWLIEN,SDWLDISP,SDWLDATA) ;UPDATE EWL ENTRY MBAA RPC: MBAA REMOVE FROM EWL
N SDWLERR,SDWLAPPT,SDWLTY
S SDWLTY=$P(SDWLDATA("WLTYPE"),U)
I SDWLDISP="SA","3,4"[SDWLTY S SDWLERR='$$SELAPPT(SDWLIEN,.SDWLDATA,.SDWLAPPT) Q:SDWLERR ; QUIT OR NOT?
I SDWLDISP="CL" Q
S %=$$DISP^MBAAWLAP(.SDWLERR,SDWLDFN,SDWLIEN,SDWLDISP,.SDWLAPPT)
S RETURN(0)=1
Q
PARSE ; MBAA RPC: MBAA REMOVE FROM EWL
Q:$G(SDWLDATA)=""
S SDWLAPPT(1)=$P(SDWLDATA,"^",1),SDWLAPPT(2)=$P(SDWLDATA,"^",2),SDWLAPPT(3)=$P(SDWLDATA,"^",3),SDWLAPPT(15)=$P(SDWLDATA,"^",4)
S SDWLAPPT(13)=$P(SDWLDATA,"^",5),SDWLAPPT(14)=$P(SDWLDATA,"^",6),SDWLAPPT(16)=$P(SDWLDATA,"^",7)
Q
;T13 Change add the code below to replace the STATUS^SDAM1 API with the SDAMA301 API ICR #
STATUS(RESULTS,DFN,SD,SC) ;get the status of an appointment ;ICR 4433
K SDARRAY,SDCOUNT
S RESULTS=""
S SDARRAY(1)=SD,SDARRAY(2)=SC,SDARRAY(4)=DFN,SDARRAY("FLDS")="22"
S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY) ; ICR
I SDCOUNT>0 S RESULTS=$P($G(^TMP($J,"SDAMA301",DFN,SC,SD)),"^",22)
;S RESULTS=$G(^TMP($J,"SDAMA301",DFN,SC,SD))
Q
SELAPPT(SDWLIEN,SDWLDATA,SDWLAPPT) ;SELECT APPOINTMENT TO CLOSE WITH
N SDWLTY,SDCL,SDSP,SDORG,SDDS,SDAP,SDA,DIR,X
S SDWLTY=$P(SDWLDATA("WLTYPE"),U)
S (SDCL,SDSP)=""
S:SDWLTY=4 SDCL=$P(SDWLDATA("WAITFORP"),U)
S:SDWLTY=3 SDSP=$P(SDWLDATA("WAITFORP"),U)
S SDORG=$P(SDWLDATA("ORIGDT"),U)
S SDDS=$$CHKENC^SDWLQSC1(SDWLIEN,SDORG,SDCL,SDSP,1) ;ICR 6418
S SDAP=$O(^TMP($J,"APPT",""))
Q:SDAP="" 1
I $O(^TMP($J,"APPT",""))'=$O(^TMP($J,"APPT",""),-1) D
. W !
. S SDA=$O(^TMP($J,"APPT",""),-1)
. I SDA=1 S DIR("B")=1
. S DIR(0)="N^1:"_SDA S DIR("A")="Select appt for Removal Reason or '^' to Quit>",DIR("?")="Select Appointment to close with the open EWL."
. D ^DIR
. S SDAP=X
Q:SDAP="^" 0
Q:'SDAP 1
D DATP^SDWLEVAL(SDAP,.SDWLAPPT) ; ICR 6417
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAARPC1 12193 printed Nov 22, 2024@17:25:05 Page 2
MBAARPC1 ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
+1 ;;1.0;Scheduling Calendar View;**1**;FEB 10, 2016;Build 85
+2 ;
+3 ;This routine has multiple RPCs created to support the mobile Scheduling apps
+4 ;Associated ICRs:
+5 ; ICR#
+6 ; 6053 DPT
+7 ; 6044 SC(
+8 ; 4433 SDAMA301
+9 ; 6417 DATP^SDWLEVAL
+10 ; 6418 $$CHKENC^SDWLQSC1
+11 ;
GETPEND(RV,DFN,DT) ; Get pending appointments for a patient MBAA RPC: MBAA PATIENT PENDING APPT
+1 ; input is patient dfn and the date to start the search and go forward
+2 KILL RETURN
+3 IF $GET(DFN)=""
SET RV(0)="1^DFN must be defined"
QUIT
+4 IF $GET(DT)=""
SET RV(0)="1^Start date must be defined"
QUIT
+5 NEW CNT,SCAP,APP,CLN,%
+6 SET CNT=""
+7 DO GETPND(.APP,DFN,DT)
+8 FOR
SET CNT=$ORDER(APP(CNT))
if CNT=""
QUIT
Begin DoDot:1
+9 SET RETURN(CNT,"COLLATERAL VISIT")=$GET(APP(CNT,13))
+10 SET RETURN(CNT,"APPOINTMENT TYPE")=$$APTYNAME^MBAAMDA2($GET(APP(CNT,9.5)))
+11 SET RETURN(CNT,"LAB")=$GET(APP(CNT,2))
+12 SET RETURN(CNT,"XRAY")=$GET(APP(CNT,3))
+13 SET RETURN(CNT,"EKG")=$GET(APP(CNT,4))
+14 SET %=$$GETCLN^MBAAMAP1(.CLN,$GET(APP(CNT,.01)))
+15 SET RETURN(CNT,"CLINIC")=$PIECE($GET(CLN("NAME")),U,2)
+16 NEW SCAP
SET %=$$GETSCAP(.SCAP,$GET(APP(CNT,.01)),DFN,CNT)
+17 SET RETURN(CNT,"LENGTH OF APP'T")=$GET(SCAP("LENGTH"))
+18 SET RETURN(CNT,"CONSULT LINK")=$GET(SCAP("CONSULT"))
+19 SET RETURN(CNT,"OTHER")=$GET(SCAP("OTHER"))
+20 ; Adding new fields
+21 SET RETURN(CNT,"CLINIC ID")=$GET(APP(CNT,.01))
+22 SET RETURN(CNT,"CURRENT STATUS")=$GET(APP(CNT,100))
+23 SET RETURN(CNT,"DESIRED APPT DATE")=$GET(APP(CNT,127))
End DoDot:1
+24 SET RETURN=($DATA(RETURN)>0)
+25 DO MERGE^MBAAMRPC(.RV,.RETURN)
+26 QUIT 1
+27 ;
GETPND(LST,PAT,SD1) ; Get pending appointments MBAA RPC: MBAA PATIENT PENDING APPT
+1 NEW SDT1
+2 SET SDT1=$$FMADD^XLFDT(SD1,0,0,-1,0)
+3 ;ICR#: 6053 DPT
FOR
SET SDT1=$ORDER(^DPT(PAT,"S",SDT1))
if SDT1=""!(SDT1'>0)
QUIT
Begin DoDot:1
+4 if $GET(SDT1)=""
QUIT
+5 NEW ERR,ARRAY,IENS
SET IENS=SDT1_","_$GET(PAT)_","
DO GETS^DIQ(2.98,IENS,".01;13;9.5;5;6;7;3;27","I","ARRAY","ERR")
+6 if $GET(ARRAY(2.98,IENS,.01,"I"))=""
QUIT
+7 if $GET(ERR)
QUIT
+8 SET LST(SDT1,.01)=$GET(ARRAY(2.98,IENS,.01,"I"))
+9 SET LST(SDT1,13)=$GET(ARRAY(2.98,IENS,13,"I"))
+10 SET LST(SDT1,9.5)=$GET(ARRAY(2.98,IENS,9.5,"I"))
+11 SET LST(SDT1,2)=$GET(ARRAY(2.98,IENS,5,"I"))
+12 SET LST(SDT1,3)=$GET(ARRAY(2.98,IENS,6,"I"))
+13 SET LST(SDT1,4)=$GET(ARRAY(2.98,IENS,7,"I"))
+14 SET LST(SDT1,5)=$GET(ARRAY(2.98,IENS,6,"I"))
+15 SET LST(SDT1,10)=$GET(ARRAY(2.98,IENS,3,"I"))
+16 SET LST(SDT1,127)=$GET(ARRAY(2.98,IENS,27,"I"))
+17 NEW R1
DO STATUS(.R1,PAT,SDT1,$GET(ARRAY(2.98,IENS,.01,"I")))
IF $GET(R1)'=""
SET LST(SDT1,100)=$PIECE(R1,";",3)
+18 KILL ARRAY,ERR,IENS
End DoDot:1
+19 ;. ;S RETURN(Y,100)=$P($$STATUS^SDAM1(PAT,Y,+AP,AP),";",3) ;ICR#: 2851 MBAA ACCESS TO SDAM1 API get appointment status
+20 ;. ;I $P($G(^DPT(PAT,"S",Y,1)),"^")'="" S RETURN(Y,127)=$P($G(^DPT(PAT,"S",Y,1)),"^")
+21 QUIT
GETSCAP(RETURN,SC,DFN,SD) ; Get clinic appointment MBAA RPC: MBAA PATIENT PENDING APPT
+1 NEW NOD0,CO,TXT
+2 IF '$DATA(DFN)!(+$GET(DFN)'>0)
SET RETURN=0
SET TXT(1)="DFN"
DO ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
+3 IF '$DATA(SC)!(+$GET(SC)'>0)
SET RETURN=0
SET TXT(1)="SC"
DO ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
+4 IF '$DATA(SD)!(+$GET(SD)'>0)
SET RETURN=0
SET TXT(1)="SD"
DO ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
+5 DO GETSCAP^MBAAMDA1(.RETURN,+SC,+DFN,+SD)
+6 IF $DATA(RETURN)
Begin DoDot:1
+7 SET NOD0=RETURN(0)
SET CO=$GET(RETURN("C"))
+8 SET RETURN("IFN")=RETURN
+9 SET RETURN("USER")=$PIECE(NOD0,U,6)
+10 SET RETURN("DATE")=$PIECE(NOD0,U,7)
+11 SET RETURN("CHECKOUT")=$PIECE(CO,U,3)
+12 SET RETURN("CHECKIN")=$PIECE(CO,U,1)
+13 SET RETURN("LENGTH")=$PIECE(NOD0,U,2)
+14 SET RETURN("CONSULT")=$PIECE($GET(RETURN("CONS")),U)
+15 SET RETURN("OTHER")=$PIECE($GET(NOD0),"^",4)
End DoDot:1
+16 QUIT 1
+17 ;
PROVCLIN(RESULTS,PROVIDER) ; Get list of clinics for a provider MBAA RPC: MBAA PROVIDER TO CLINIC
+1 ; input is provider id (IEN for VA(200))
+2 KILL RESULTS
+3 IF $GET(PROVIDER)=""
SET RESULTS(0)="1^Provider IEN is required."
QUIT
+4 ;ICR#: 6044 SC(
SET (CNT,CLIN)=0
FOR
SET CLIN=$ORDER(^SC(CLIN))
if CLIN'>0
QUIT
SET PROV=0
FOR
SET PROV=$ORDER(^SC(CLIN,"PR","B",PROV))
if PROV'>0
QUIT
SET REC=0
FOR
SET REC=$ORDER(^SC(CLIN,"PR","B",PROV,REC))
if REC'>0
QUIT
Begin DoDot:1
+5 ;T13 Change to use FM
+6 NEW ARRAY
DO GETS^DIQ(44,CLIN_",",".01;2","I","ARRAY")
+7 SET CLINNAME=$GET(ARRAY(44,CLIN_",",.01,"I"))
+8 SET TYPE=$GET(ARRAY(44,CLIN_",",2,"I"))
+9 if $GET(TYPE)'="C"
QUIT
+10 ;Q:$P(^SC(CLIN,0),"^",3)'="C" ;ICR#: 6044 SC(
+11 ;N IENS S IENS=$G(REC)_","_$G(CLIN)_"," S PROVIDER=$$GET1^DIQ(44.1,IENS,".01","I")
+12 ;Q:$P(^SC(CLIN,0),"^",3)'="C" ;ICR#: 6044 SC(
+13 if $GET(PROV)'=$GET(PROVIDER)
QUIT
+14 ;S CLINNAME=$P(^SC(CLIN,0),"^") ;ICR#: 6044 SC(
+15 SET RESULTS(CNT)=CLIN_"^"_CLINNAME
SET CNT=CNT+1
+16 KILL CLINNAME,TYPE
End DoDot:1
+17 KILL CLIN,PROV,PROVIDER,CNT,REC,TYPE
+18 if $GET(RESULTS(0))=""
SET RESULTS(0)="1^Provider is not assigned to any clinics."
+19 QUIT
+20 ;Line tags REMREC, UPDTEWL, PARSE, UPDATE have been commented out due to being descoped from the first release
+21 ;REMREC(RESULTS,DFN,CLINIC,PROVIDER,RECALLDT,PTRECDT) ; Remove a patient from the Recall list MBAA RPC: MBAA REMOVE FROM RECALL LIST
+22 ; Input Parameters:
+23 ; DFN = Patient ID
+24 ; Clinic = Clinic ID - IEN from the Hospital Location file (#44)
+25 ; PROVIDER = Provider IEN (optional)
+26 ; RECALLDT = The recall date requested by the provider
+27 ; PTRECDT = The recall date requested by the patient
+28 ; Either the RECALLDT or the PTRECDT is required.
+29 ;
+30 ; Checks for multiple entries on the recall list that are for the same patient, provider, clinic and recall dates and deletes all
+31 ; Output:
+32 ; If successful:
+33 ; RESULTS="1^DELETED" the patient was removed from the recall list for the clinic
+34 ; If not successful:
+35 ; RESULTS="0^DFN MISSING"
+36 ; RESULTS="0^CLINIC ID MISSING"
+37 ; RESULTS="0^User doesn't have the provider key."
+38 ;
+39 ;S RESULTS(0)=""
+40 ;I $G(DFN)="" S RESULTS(0)="0^DFN MISSING" Q
+41 ;I $G(CLINIC)="" S RESULTS(0)="0^CLINIC ID MISSING" Q
+42 ;T13 Changes to use FM
+43 ;N JX S JX=$$GET1^DIQ(2,$G(DFN),.01) I $G(JX)="" S RESULTS(0)="0^NOT A PATIENT" Q ;ICR#: 6053 DPT
+44 ;N JX S JX=$$GET1^DIQ(44,$G(CLINIC),.01) I $G(JX)="" S RESULTS(0)="0^NOT A CLINIC" Q ;ICR#: 6044 SC(
+45 ;I '$D(^DPT(DFN,0)) S RESULTS(0)="0^NOT A PATIENT" Q ;ICR#: 6053 DPT
+46 ;I '$D(^SC(CLINIC,0)) S RESULTS(0)="0^NOT A CLINIC" Q ;ICR#: 6044 SC(
+47 ;T13 Change to use FM
+48 ;S (SDPRV,KEY,SDFLAG)="" S SDPRV=$P($G(^SD(403.5,CLINIC,0)),U,5) I SDPRV'="" S KEY=$P($G(^SD(403.54,SDPRV,0)),U,7) D ;ICR#: 6045 SD(403.5
+49 ;N CLIN S CLIN=$O(^SD(403.5,"E",CLINIC,0))
+50 ;I $G(CLIN)>0 S (SDPRV,KEY,SDFLAG)="" S SDPRV=$$GET1^DIQ(403.5,CLIN_",",4,"I") I SDPRV'="" S KEY=$$GET1^DIQ(403.54,SDPRV_",",6,"I") D ;ICR#: 6158 SD(403.54
+51 ;.Q:KEY=""
+52 ;.N VALUE
+53 ;.S VALUE=$$LKUP^XPDKEY(KEY) K KY D OWNSKEY^XUSRB(.KY,VALUE,DUZ) ;ICR#: 3277 XUSRB
+54 ;.I $G(KY(0))=0 S RESULTS(0)="0^User doesn't have the security key."
+55 ;Q:$G(RESULTS(0))'=""
+56 ;S IEN=0 F S IEN=$O(^SD(403.5,"E",CLINIC,IEN)) Q:IEN'>0 D ;ICR#: 6045 SD(403.5
+57 ;.K NODE,PROV,PROVDT,PTDT,RESULTS(0),XDFN,OK
+58 ;.S OK=0
+59 ;.;T13 Change to use FM
+60 ;.;S NODE=$G(^SD(403.5,IEN,0)) ;ICR#: 6045 SD(403.5
+61 ;.;S XDFN=$P(NODE,"^")
+62 ;.N ARRAY,ERR D GETS^DIQ(403.5,IEN_",",".01;4;5;5.5","I","ARRAY","ERR")
+63 ;.S XDFN=$G(ARRAY(403.5,IEN_",",.01,"I")),PROV=$G(ARRAY(403.5,IEN_",",4,"I")),PROVDT=$G(ARRAY(403.5,IEN_",",5,"I")),PTDT=$G(ARRAY(403.5,IEN_",",5.5,"I"))
+64 ;.I $G(XDFN)'=DFN S RESULTS(0)="0^PATIENT NOT ON RECALL LIST" Q
+65 ;.;S PROV=$P(NODE,"^",5),PROVDT=$P(NODE,"^",6),PTDT=$P(NODE,"^",12),DFN1=$P(NODE,"^",1)
+66 ;.;I $G(PROV)'=$G(PROVIDER) Q ;S RESULTS(0)="0^PROVIDER DOESN'T MATCH" Q
+67 ;.;I $G(PROVDT)'=$G(RECALLDT) Q ;S RESULTS(0)="0^PROVIDER RECALL DATE DOESN'T MATCH" Q
+68 ;.;I $G(PTRECDT)'="" I $G(PTDT)'=$G(PTRECDT) S RESULTS(0)="0^PATIENT RECALL DATE DOESN'T MATCH" Q
+69 ;.;I $G(DFN1)'=$G(DFN) S RESULTS(0)="0^PATIENT MISMATCH" Q
+70 ;.S DIK="^SD(403.5,",DA=IEN D ^DIK ;ICR#: 6045 SD(403.5
+71 ;.S OK=1
+72 ;I OK=1 S RESULTS(0)="1^DELETED"
+73 ;I OK=0 S RESULTS(0)="0^NOT ON RECALL LIST"
+74 ;K SDPRV,KEY,SDFLAG,VALUE,IEN,DIK,DA,OK
+75 ;Q
UPDTEWL(RESULTS,DFN,SDWLIEN,SDWLDISP,SDWLDATA) ; Update or remove a patient on the EWL MBAA RPC: MBAA REMOVE FROM EWL
+1 ;Input paramters:
+2 ; DFN - Patient DFN
+3 ; EWLIEN - for EWL Record to be updated
+4 ; DISP - The disposition code of the EWL entry:
+5 ; D:DEATH;NC:REMOVED/NON-VA CARE;SA:REMOVED/SCHEDULED-ASSIGNED;CC:REMOVED/VA CONTRACT CARE;NN:REMOVED/NO LONGER NECESSARY;ER:ENTERED IN ERROR;CL:CLINIC CHANGE
+6 ; SDWLDATA array:
+7 ; $P(1) = SDWLAPPT(1)=SCHEDULED DATE OF APPT
+8 ; $P(2) = SDWLAPPT(2)=PTR TO APPT CLINIC (CLINIC WHERE APPT MADE)
+9 ; $P(4) = SDWLAPPT(15)=APPOINTMENT INSTITUTION (PTR to Institution File)
+10 ; $P(5) = SDWLAPPT(13)=APPT STOP CODE (PTR to file 40.7)
+11 ; $P(6) = SDWLAPPT(14)=APPT CREDIT STOP CODE (PTR to file 40.7)
+12 ; $P(7) = SDWLAPPT(16)=APPT STATION NUMBER (Free Text) MUST BE AN IEN FROM DIC(4 but is not a ptr field)
+13 ; $P(3) = SDWLAPPT(3)=APPT STATUS (Set of codes: 'R' FOR Scheduled/Kept;
+14 ; 'I' FOR Inpatient;
+15 ; 'NS' FOR No-Show;
+16 ; 'NSR' FOR No_Show, Rescheduled;
+17 ; 'CP' FOR Canceled by Patient;
+18 ; 'CPR' FOR Canceled by Patient, Rescheduled;
+19 ; 'CC' FOR Canceled by Clinic;
+20 ; 'CCR' FOR Canceled by Clinic, Rescheduled;
+21 ; 'NT' FOR No Action Taken; )
+22 ;Output:
+23 ; RESULTS(0)=1 - Successful
+24 ; RESULTS(0)="0^DFN is required" - DFN parameter missing
+25 ; RESULTS(0)="0^SDWLIEN is required" - SDWLIEN parameter is missing
+26 ; RESULTS(0)="0^Patient not on EWL" - Patient is not on the EWL
+27 ; RESULTS(0)="0^Disposition is missing."
+28 ; RESULTS(0)="0^Disposition is SA but missing Appointment data."
+29 ;
+30 SET RESULTS(0)=1
+31 IF $GET(DFN)=""
SET RESULTS(0)="0^DFN is required"
QUIT
+32 IF $GET(SDWLIEN)=""
SET RESULTS(0)="0^SDWLIEN is required"
QUIT
+33 ;ICR#: 6046 SDWL(409.3
IF '$DATA(^SDWL(409.3,"B",DFN))
SET RESULTS(0)="0^Patient not on EWL"
QUIT
+34 IF $GET(SDWLDISP)=""
SET RESULTS(0)="0^Disposition is missing."
QUIT
+35 IF ($GET(SDWLDISP)="SA"&($GET(SDWLDATA)=""))
SET RESULTS(0)="0^Disposition is SA but missing Appointment data."
QUIT
+36 ;T13 Change to use FM
+37 ;ICR#: 6046 SDWL(409.3
NEW TYPE
SET TYPE=$$GET1^DIQ(409.3,SDWLIEN_",",23,"I")
IF $GET(TYPE)="C"
SET RESULTS(0)="0^Patient not on EWL"
QUIT
+38 ;ICR#: 6046 SDWL(409.3
IF $PIECE(^SDWL(409.3,SDWLIEN,0),"^",17)="C"
SET RESULTS(0)="0^Patient not on EWL"
QUIT
+39 DO PARSE
+40 ; W !,"Another User is Editing this Entry. Try Later." Q
IF '$$LOCK^MBAAWLAP(.SDWLERR,SDWLIEN)
+41 SET %=$$DETAIL^MBAAWLAP(.SDWLDATA,SDWLIEN)
+42 if SDWLDISP=""
GOTO ENQ
+43 DO UPDATE(DFN,SDWLIEN,SDWLDISP,.SDWLDATA)
ENQ ; MBAA RPC: MBAA REMOVE FROM EWL
+1 SET %=$$UNLOCK^MBAAWLAP(SDWLIEN)
+2 QUIT
UPDATE(SDWLDFN,SDWLIEN,SDWLDISP,SDWLDATA) ;UPDATE EWL ENTRY MBAA RPC: MBAA REMOVE FROM EWL
+1 NEW SDWLERR,SDWLAPPT,SDWLTY
+2 SET SDWLTY=$PIECE(SDWLDATA("WLTYPE"),U)
+3 ; QUIT OR NOT?
IF SDWLDISP="SA"
IF "3,4"[SDWLTY
SET SDWLERR='$$SELAPPT(SDWLIEN,.SDWLDATA,.SDWLAPPT)
if SDWLERR
QUIT
+4 IF SDWLDISP="CL"
QUIT
+5 SET %=$$DISP^MBAAWLAP(.SDWLERR,SDWLDFN,SDWLIEN,SDWLDISP,.SDWLAPPT)
+6 SET RETURN(0)=1
+7 QUIT
PARSE ; MBAA RPC: MBAA REMOVE FROM EWL
+1 if $GET(SDWLDATA)=""
QUIT
+2 SET SDWLAPPT(1)=$PIECE(SDWLDATA,"^",1)
SET SDWLAPPT(2)=$PIECE(SDWLDATA,"^",2)
SET SDWLAPPT(3)=$PIECE(SDWLDATA,"^",3)
SET SDWLAPPT(15)=$PIECE(SDWLDATA,"^",4)
+3 SET SDWLAPPT(13)=$PIECE(SDWLDATA,"^",5)
SET SDWLAPPT(14)=$PIECE(SDWLDATA,"^",6)
SET SDWLAPPT(16)=$PIECE(SDWLDATA,"^",7)
+4 QUIT
+5 ;T13 Change add the code below to replace the STATUS^SDAM1 API with the SDAMA301 API ICR #
STATUS(RESULTS,DFN,SD,SC) ;get the status of an appointment ;ICR 4433
+1 KILL SDARRAY,SDCOUNT
+2 SET RESULTS=""
+3 SET SDARRAY(1)=SD
SET SDARRAY(2)=SC
SET SDARRAY(4)=DFN
SET SDARRAY("FLDS")="22"
+4 ; ICR
SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
+5 IF SDCOUNT>0
SET RESULTS=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,SC,SD)),"^",22)
+6 ;S RESULTS=$G(^TMP($J,"SDAMA301",DFN,SC,SD))
+7 QUIT
SELAPPT(SDWLIEN,SDWLDATA,SDWLAPPT) ;SELECT APPOINTMENT TO CLOSE WITH
+1 NEW SDWLTY,SDCL,SDSP,SDORG,SDDS,SDAP,SDA,DIR,X
+2 SET SDWLTY=$PIECE(SDWLDATA("WLTYPE"),U)
+3 SET (SDCL,SDSP)=""
+4 if SDWLTY=4
SET SDCL=$PIECE(SDWLDATA("WAITFORP"),U)
+5 if SDWLTY=3
SET SDSP=$PIECE(SDWLDATA("WAITFORP"),U)
+6 SET SDORG=$PIECE(SDWLDATA("ORIGDT"),U)
+7 ;ICR 6418
SET SDDS=$$CHKENC^SDWLQSC1(SDWLIEN,SDORG,SDCL,SDSP,1)
+8 SET SDAP=$ORDER(^TMP($JOB,"APPT",""))
+9 if SDAP=""
QUIT 1
+10 IF $ORDER(^TMP($JOB,"APPT",""))'=$ORDER(^TMP($JOB,"APPT",""),-1)
Begin DoDot:1
+11 WRITE !
+12 SET SDA=$ORDER(^TMP($JOB,"APPT",""),-1)
+13 IF SDA=1
SET DIR("B")=1
+14 SET DIR(0)="N^1:"_SDA
SET DIR("A")="Select appt for Removal Reason or '^' to Quit>"
SET DIR("?")="Select Appointment to close with the open EWL."
+15 DO ^DIR
+16 SET SDAP=X
End DoDot:1
+17 if SDAP="^"
QUIT 0
+18 if 'SDAP
QUIT 1
+19 ; ICR 6417
DO DATP^SDWLEVAL(SDAP,.SDWLAPPT)
+20 QUIT 1
