MBAAMAP1 ;OIT-PD/VSL - APPOINTMENT API ;02/10/2016
;;1.0;Scheduling Calendar View;**1,7**;Aug 27, 2014;Build 16
;
;Associated ICRs
; ICR#
; 10104 XLFSTR
; 10103 XLFDT
; 6934 TAG PTFU uses $O(^SCE("ADFN",DFN,SDT),-1)
;
;code removed below is scheduled for a future release of MBAA
CLNCK(RETURN,CLN) ;Check clinic for valid stop code restriction. Called by RPC MBAA APPOINTMENT MAKE
; INPUT: CLN = IEN of Clinic
;
; OUTPUT: 1 if no error or 0^error message
N PSC,SSC,ND0,VAL,FLDS
S RETURN=0
I CLN="" D ERRX^MBAAAPIE(.RETURN,"CLNINV") Q 0
D GETCLN^MBAAMDA1(.FLDS,CLN,1,0,0)
I '$D(FLDS) D ERRX^MBAAAPIE(.RETURN,"CLNNDFN") Q 0
I $G(FLDS(2))'="C" Q 1 ;not a Clinic
S %=$$SCREST(.RETURN,FLDS(8),"P")
Q:'% % Q:FLDS(2503)="" 1
S %=$$SCREST(.RETURN,FLDS(2503),"S")
S RETURN=%
Q RETURN
;
SCREST(RETURN,SCIEN,TYP) ;check stop code restriction in file 40.7 for a clinic. MBAA RPC: MBAA APPOINTMENT MAKE
; INPUT: SCIEN = IEN of Stop Code
; TYP = Stop Code Type, Primary (P) or Secondary (S)
; DIS = Message Display, 1 - Display or 0 No Display
;
; OUTPUT: 1 if no error, or 0^error message
;
N SCN,RTY,CTY,RDT,STR,STYP,FLDS,TEXT
S STYP="("_$S(TYP="P":"Prim",1:"Second")_"ary)"
S RETURN=0
I +SCIEN<1 S TEXT(1)=STYP D ERRX^MBAAAPIE(.RETURN,"CLNSCIN",.TEXT) Q 0
S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
D GETCSC^MBAAMDA1(.FLDS,SCIEN)
S RTY=$G(FLDS(5)),RDT=$G(FLDS(6))
I RTY="" D Q 0
. S TEXT(1)=$G(FLDS(1)),TEXT(2)=STYP
. D ERRX^MBAAAPIE(.RETURN,"CLNSCNR",.TEXT)
I CTY'[("^"_RTY_"^") D Q 0
. S TEXT(1)=$G(FLDS(1)),TEXT(2)=$S(TYP="P":"Prim",1:"Second")_"ary"
. D ERRX^MBAAAPIE(.RETURN,"CLNSCPS",.TEXT)
I RDT>DT D Q 0
. S TEXT(1)=$G(FLDS(1)),TEXT(2)=$$FMTE^XLFDT(RDT,"1F"),TEXT(3)=STYP ;ICR#: 10103 XLFDT
. D ERRX^MBAAAPIE(.RETURN,"CLNSCRD",.TEXT)
S RETURN=1
Q 1
; ;
GETCLN(RETURN,CLN) ; Get Clinic data MBAA RPC: MBAA PATIENT PENDING APPT
; INPUT: CLN = IEN of Clinic
N DATA
S RETURN=0
D GETCLN^MBAAMDA1(.DATA,CLN,1,1,1)
I '$D(DATA) D ERRX^MBAAAPIE(.RETURN,"CLNNFND") Q 0
M RETURN=DATA
S RETURN=1
Q 1
;
;LSTCLNS(RETURN,SEARCH,START,NUMBER) ; Return clinics filtered by name.
; N LST
; D LSTCLNS^MBAAMDA1(.LST,$G(SEARCH),.START,$G(NUMBER))
; D BLDLST^MBAAMAPI(.RETURN,.LST)
; Q 1
; ;
CLNRGHT(RETURN,CLN) ; Verifies (DUZ) user access to Clinic Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT
N DATA,TXT
S RETURN=0
D GETCLN^MBAAMDA1(.DATA,CLN,1)
I DATA(2500)="Y" D Q RETURN
. I $D(DATA(2501,DUZ,.01))>0 S RETURN=1 Q
. E D
. . S RETURN=0 S TXT(1)=DATA(.01),TXT(2)=$C(10)
. . D ERRX^MBAAAPIE(.RETURN,"CLNURGT",.TXT)
. . S RETURN("CLN")=DATA(.01)
E S RETURN=1 Q 1
;
;CLNVSC(RETURN,SC) ; Verifies clinic stop code validation
; N DATA
; S RETURN=0
; D GETCSC^MBAAMDA1(.DATA,+SC)
; I $S('$D(DATA):1,'DATA(2):0,1:$G(DATA(2))'>DT) D Q RETURN
; . S TEXT(1)=+SC
; . D ERRX^MBAAAPIE(.RETURN,"CLNSCIN",.TEXT)
; . S RETURN=0
; S RETURN=1
; Q RETURN
;
GETSCAP(RETURN,SC,DFN,SD) ; Get clinic appointment Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT
N NOD0,CO
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(NOD0,U,11)
Q 1
;
SLOTS(RETURN,SC) ; Get available slots MBAA RPC: MBAA GET CLINIC AVAILABILITY
D SLOTS^MBAAMDA2(.RETURN,SC)
S RETURN=1
Q 1
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;SCEXST(RETURN,CSC) ; Get Stop Cod Exception status
; N RET,LAST
; D SCEXST^MBAAMDA2(.RET,CSC)
; S RETURN=RET
; I RET>0 S LAST=99999999999,LAST=$O(RET("EFFECTIVE DATE",LAST),-1) D
; . M RETURN=RET("EFFECTIVE DATE",LAST)
; Q RETURN
; ;
LSTAPPT(RETURN,SEARCH,START,NUMBER) ; Lists appointment types MBAA RPC: MBAA APPOINTMENT LIST BY NAME
N RET,DL,IN
S:'$D(START) START="" S:'$D(SEARCH) SEARCH=""
S:'$G(NUMBER) NUMBER=""
S RETURN=0
D LSTAPPT^MBAAMDA2(.RET,$$UP^XLFSTR(SEARCH),.START,NUMBER) ;ICR#: 10104 XLFSTR
S RETURN(0)=RET("DILIST",0)
S DL="DILIST"
F IN=1:1:$P(RETURN(0),U,1) D
. S RETURN(IN)=""
. S RETURN(IN,"ID")=RET(DL,2,IN)
. S RETURN(IN,"NAME")=RET(DL,"ID",IN,".01")
S RETURN=1
Q 1
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;GETAPPT(RETURN,TYPE) ; Returns Appointment Type detail
; D GETAPPT^MBAAMDA2(.RETURN,TYPE,1,1,1)
; S RETURN=1
; Q 1
; ;
;GETELIG(RETURN,ELIG) ; Returns Eligibility Code detail
; D GETELIG^MBAAMDA2(.RETURN,ELIG,1,1,1)
; S RETURN=1
; Q 1
; ;
;GETPEND(RETURN,DFN,DT) ; Get pending appointments
; N CNT,SCAP,APP,CLN,%
; S CNT=""
; D GETPEND^MBAAMDA2(.APP,DFN,DT)
; F S CNT=$O(APP(CNT)) Q:CNT="" D
; . S RETURN(CNT,"COLLATERAL VISIT")=APP(CNT,13)
; . S RETURN(CNT,"APPOINTMENT TYPE")=$$APTYNAME^MBAAMDA2(APP(CNT,9.5))
; . S RETURN(CNT,"LAB")=APP(CNT,2)
; . S RETURN(CNT,"XRAY")=APP(CNT,3)
; . S RETURN(CNT,"EKG")=APP(CNT,4)
; . S %=$$GETCLN^MBAAMAP1(.CLN,APP(CNT,.01))
; . S RETURN(CNT,"CLINIC")=$P(CLN("NAME"),U,2)
; . S %=$$GETSCAP^MBAAMAP1(.SCAP,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=($D(RETURN)>0)
; Q 1
; ;
;GETAPTS(RETURN,DFN,SD) ; Get patient appointments
; S DFN=+DFN
; D GETAPTS^MBAAMDA2(.RETURN,+DFN,.SD)
; S RETURN=($D(RETURN)>0)
; Q 1
; ;
LSTCRSNS(RETURN,SEARCH,START,NUMBER) ; MBAA RPC: MBAA LIST CANCELLATION REASONS
N LST
M LST=RETURN
D LSTCRSNS^MBAAMDA2(.LST,$$UP^XLFSTR($G(SEARCH)),.START,$G(NUMBER))
D BLDLST^MBAAMAPI(.RETURN,.LST)
Q RETURN
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;FRSTAVBL(RETURN,SC) ; Get first available date
; D FRSTAVBL^MBAAMDA2(.RETURN,SC)
; Q 1
; ;
;linetag LSTCAPTS is removed, it is not needed until the next enhancement of MBAA
;LSTCAPTS(RETURN,SC,SDBEG,SDEND,STAT) ; Returns clinic appointments filtered by date and status
;N APTS,CNT,IND,FAPTS,GROUPS
;S CNT=0,IND=0
;S RETURN=0
;D GROUP^SDAM($P(STAT,U),.GROUPS)
;D LSTCAPTS^MBAAMDA1(.APTS,SC,.SDBEG,.SDEND)
;D BLDAPTS(.RETURN,.APTS,SC,,.GROUPS)
;S RETURN=1
;Q 1
;
;linetag LSTPAPTS is removed, this functionality is not needed until a future enhancement of MBAA
;LSTPAPTS(RETURN,DFN,SDBEG,SDEND,STAT) ; Returns patient appointments filtered by date and status
;N APTS,CNT,IND,FAPTS,GROUPS
;S CNT=0,IND=0
;S RETURN=0
;D GROUP^SDAM($P(STAT,U),.GROUPS)
;D LSTPAPTS^MBAAMDA1(.APTS,DFN,.SDBEG,.SDEND)
;D BLDAPTS(.RETURN,.APTS,,DFN,.GROUPS)
;S RETURN=1
;Q 1
;
;linetag BLDAPTS is removed, it is not needed until the next enhancement of MBAA
;BLDAPTS(RETURN,APTS,SSC,SDFN,GROUPS) ; Build appointment list
;N IND,DFN,SC,VA,VADM,CDATA,SDATA,SDDA,SDSTAT,CAPT,PAPT
;F IND=0:0 S IND=$O(APTS(IND)) Q:IND="" D
;. S SDATA=APTS(IND,"SDATA")
;. Q:'$G(SDFN)&($P(SDATA,U,2)["C")
;. S DFN=$S('$G(SDFN):+APTS(IND,"CDATA"),1:SDFN)
;. S SD=APTS(IND,"SD")
;. S SC=$S('$G(SSC):APTS(IND,"SC"),1:SSC)
;. S SDDA=APTS(IND,"SDDA")
;. S CDATA=$G(APTS(IND,"CDATA"))
;. S SDSTAT=$$STATUS^SDAM1(DFN,SD,SC,SDATA,$S($D(SDDA):SDDA,1:""))
;. Q:'$$CHK^SDAM1(,,,,.GROUPS,SDSTAT)
;. Q:$G(SSC)&(($P(CDATA,U,9)="C")!($P(SDATA,U,2)["C")&($G(SC)))
;. S CNT=CNT+1
;. D 2^VADPT
;. S RETURN(CNT,"BID")=VA("BID")
;. S RETURN(CNT,"NAME")=VADM(1)
;. D GETPAPT^MBAAMDA4(.PAPT,DFN,SD)
;. S RETURN(CNT,"GAF")=$$GAFREQ(DFN,SC,$P(SDATA,U,11))
;. S RETURN(CNT,"SD")=SD
;. S RETURN(CNT,"STAT")=SDSTAT
;. S RETURN(CNT,"STATI")=PAPT(3,"I")
;. S RETURN(CNT,"OE")=PAPT(21,"I")
;. S RETURN(CNT,"DFN")=DFN
;. S RETURN(CNT,"LAB")=$P(SDATA,U,3)
;. S RETURN(CNT,"XRAY")=$P(SDATA,U,4)
;. S RETURN(CNT,"EKG")=$P(SDATA,U,5)
;. S RETURN(CNT,"SC")=SC
;. D GETCAPT^MBAAMDA4(.CAPT,DFN,SD)
;. S RETURN(CNT,"LEN")=CAPT(1)
;. S RETURN(CNT,"CLINIC")=PAPT(.01,"E")
;. S RETURN(CNT,"SDDA")=APTS(IND,"SDDA")
;. S:$G(APTS(IND,"CONS"))>0 RETURN(CNT,"CSTAT")=$$CNSSTAT^MBAAMEXT(APTS(IND,"CONS"))
;Q
;
;GAFREQ(DFN,SC,CVSIT) ;
; N SDELIG,SDGAF,SDGAFST
; S SDELIG=$$ELSTAT^SDUTL2(DFN)
; I $$MHCLIN^SDUTL2(SC),'($$COLLAT^SDUTL2(SDELIG)!$G(CVSIT)) D Q SDGAFST
; . S SDGAF=$$NEWGAF^SDUTL2(DFN),SDGAFST=$P(SDGAF,"^") Q
; Q 0
; ;
;GETCSC(RETURN,SC) ; Get clinic stop code
; N CLN
; D GETCLN^MBAAMDA1(.CLN,SC,1)
; D GETCSC^MBAAMDA1(.RETURN,$G(CLN(8)))
; S RETURN=1
; Q 1
; ;
CPAIR(RETURN,SC) ;Validate primary stop code, get credit pair MBAA RPC: MBAA APPOINTMENT MAKE
;Input: SC=HOSPITAL LOCATION record IFN
;Input: RETURN=variable to return clinic credit pair (pass by reference)
;Output: 1=success, 0=invalid primary stop code
N SDSSC,CLN,CS ;WCJ;MBAA*1*7; Newed CLN & CS
D GETCLN^MBAAMDA1(.CLN,SC,1)
Q:'$G(CLN(8)) 0
D GETCSC^MBAAMDA1(.CS,CLN(8))
S RETURN=$G(CS(1)),RETURN=$S(RETURN<100:0,RETURN>999:0,1:RETURN)
Q:RETURN'>0 0
K CS D GETCSC^MBAAMDA1(.CS,CLN(2503))
S SDSSC=$G(CS(1)),RETURN=RETURN_$S(SDSSC<100:"000",SDSSC>999:"000",1:SDSSC)
Q 1
;
PTFU(RETURN,DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months)
;Input: DFN=patient ifn
;Input: SC=clinic ifn
;Output: '1' if seen within 24 months, '0' otherwise
;
Q:'DFN!'SC 0 ;variable check
N SDBDT,SDT,SDX,SDY,SDCP1,SDCP2,SDENC,SDCT
;set up variables
S SDBDT=(DT-20000)+.24,SDT=DT_.999999,SDY=0
S SDX=$$CPAIR(.SDCP1,SC) ;get credit pair for this clinic
Q:'SDX 0
;Iterate through encounters
F S SDT=$O(^SCE("ADFN",DFN,SDT),-1) Q:(SDT<SDBDT)!SDY D
.S SDENC=0 F S SDENC=$O(^SCE("ADFN",DFN,SDT,SDENC)) Q:'SDENC!SDY D
..Q:$$GET1^DIQ(409.68,SDENC,.06,"I") ;parent encounters only
..S SDX=$$GET1^DIQ(409.68,SDENC,.04,"I") ;get clinic
..Q:'SDX
..S SDX=$$CPAIR(.SDCP2,SDX) ;get credit pair for this clinic
..Q:'SDX
..S SDY=SDCP1=SDCP2 ;compare credit pairs
..Q
.Q
Q SDY
;
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;HASPEND(RETURN,DFN,DT) ; Check if patient has panding appointments
; D HASPEND^MBAAMDA2(.RETURN,DFN,DT)
; Q 1
; ;
;LSTSRT(RETURN) ;List scheduling request types
; K RETURN
; S RETURN=1
; D LSTSCOD^MBAAMDAL(2.98,25,.RETURN)
; Q 1
; ;
;LSTAPPST(RETURN) ;List appointment statuses
; K RETURN
; S RETURN=1
; D LSTSCOD^MBAAMDAL(2.98,3,.RETURN)
; Q 1
; ;
;LSTHLTP(RETURN) ;List hospital location types
; K RETURN
; S RETURN=1
; D LSTSCOD^MBAAMDAL(44,2,.RETURN)
; Q 1
;
;
;WCJ;MAAA*1*7;old PTFU tag saved for posterity
;deemed too slow since it goes through the entire outpatient encounter file
;and while it uses a screen, it was still way too slow
;
PTFU2(RETURN,DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months) Called by RPC MBAA APPOINTMENT MAKE
;Input: DFN=patient ifn
;Input: SC=clinic ifn
;Output: '1' if seen within 24 months, '0' otherwise
;
Q:'DFN!'SC 0 ;variable check
S RETURN=1
N SDBDT,SDT,SDX,SDY,SDZ,SDCP,SDCP1,SC0,SDENC,SDCT,LST,ENC,FLDS
;set up variables
S SDBDT=(DT-20000)+.24,SDT=DT_.999999,SDY=0
S SDX=$$CPAIR(.SDCP,SC) ;get credit pair for this clinic
;Iterate through encounters
D LSTAENC^MBAAMDA1(.LST,DFN)
S FLDS(.04)="CLINIC",FLDS(.06)="PARENT"
D BLDLST^MBAAMAPI(.ENC,.LST,.FLDS)
F S SDT=$O(ENC(SDT),-1) Q:'SDT!SDY D
. Q:ENC(SDT,"PARENT")]"" ;parent encounters only
. Q:ENC(SDT,"NAME")<SDBDT
. S SDX=$$CPAIR(.SDCP1,ENC(SDT,"CLINIC")) ;get credit pair for encounter
. S SDY=SDCP=SDCP1 ;compare credit pairs
. Q
Q SDY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAAMAP1 12310 printed Dec 13, 2024@02:14:48 Page 2
MBAAMAP1 ;OIT-PD/VSL - APPOINTMENT API ;02/10/2016
+1 ;;1.0;Scheduling Calendar View;**1,7**;Aug 27, 2014;Build 16
+2 ;
+3 ;Associated ICRs
+4 ; ICR#
+5 ; 10104 XLFSTR
+6 ; 10103 XLFDT
+7 ; 6934 TAG PTFU uses $O(^SCE("ADFN",DFN,SDT),-1)
+8 ;
+9 ;code removed below is scheduled for a future release of MBAA
CLNCK(RETURN,CLN) ;Check clinic for valid stop code restriction. Called by RPC MBAA APPOINTMENT MAKE
+1 ; INPUT: CLN = IEN of Clinic
+2 ;
+3 ; OUTPUT: 1 if no error or 0^error message
+4 NEW PSC,SSC,ND0,VAL,FLDS
+5 SET RETURN=0
+6 IF CLN=""
DO ERRX^MBAAAPIE(.RETURN,"CLNINV")
QUIT 0
+7 DO GETCLN^MBAAMDA1(.FLDS,CLN,1,0,0)
+8 IF '$DATA(FLDS)
DO ERRX^MBAAAPIE(.RETURN,"CLNNDFN")
QUIT 0
+9 ;not a Clinic
IF $GET(FLDS(2))'="C"
QUIT 1
+10 SET %=$$SCREST(.RETURN,FLDS(8),"P")
+11 if '%
QUIT %
if FLDS(2503)=""
QUIT 1
+12 SET %=$$SCREST(.RETURN,FLDS(2503),"S")
+13 SET RETURN=%
+14 QUIT RETURN
+15 ;
SCREST(RETURN,SCIEN,TYP) ;check stop code restriction in file 40.7 for a clinic. MBAA RPC: MBAA APPOINTMENT MAKE
+1 ; INPUT: SCIEN = IEN of Stop Code
+2 ; TYP = Stop Code Type, Primary (P) or Secondary (S)
+3 ; DIS = Message Display, 1 - Display or 0 No Display
+4 ;
+5 ; OUTPUT: 1 if no error, or 0^error message
+6 ;
+7 NEW SCN,RTY,CTY,RDT,STR,STYP,FLDS,TEXT
+8 SET STYP="("_$SELECT(TYP="P":"Prim",1:"Second")_"ary)"
+9 SET RETURN=0
+10 IF +SCIEN<1
SET TEXT(1)=STYP
DO ERRX^MBAAAPIE(.RETURN,"CLNSCIN",.TEXT)
QUIT 0
+11 SET CTY=$SELECT(TYP="P":"^P^E^",1:"^S^E^")
+12 DO GETCSC^MBAAMDA1(.FLDS,SCIEN)
+13 SET RTY=$GET(FLDS(5))
SET RDT=$GET(FLDS(6))
+14 IF RTY=""
Begin DoDot:1
+15 SET TEXT(1)=$GET(FLDS(1))
SET TEXT(2)=STYP
+16 DO ERRX^MBAAAPIE(.RETURN,"CLNSCNR",.TEXT)
End DoDot:1
QUIT 0
+17 IF CTY'[("^"_RTY_"^")
Begin DoDot:1
+18 SET TEXT(1)=$GET(FLDS(1))
SET TEXT(2)=$SELECT(TYP="P":"Prim",1:"Second")_"ary"
+19 DO ERRX^MBAAAPIE(.RETURN,"CLNSCPS",.TEXT)
End DoDot:1
QUIT 0
+20 IF RDT>DT
Begin DoDot:1
+21 ;ICR#: 10103 XLFDT
SET TEXT(1)=$GET(FLDS(1))
SET TEXT(2)=$$FMTE^XLFDT(RDT,"1F")
SET TEXT(3)=STYP
+22 DO ERRX^MBAAAPIE(.RETURN,"CLNSCRD",.TEXT)
End DoDot:1
QUIT 0
+23 SET RETURN=1
+24 QUIT 1
+25 ; ;
GETCLN(RETURN,CLN) ; Get Clinic data MBAA RPC: MBAA PATIENT PENDING APPT
+1 ; INPUT: CLN = IEN of Clinic
+2 NEW DATA
+3 SET RETURN=0
+4 DO GETCLN^MBAAMDA1(.DATA,CLN,1,1,1)
+5 IF '$DATA(DATA)
DO ERRX^MBAAAPIE(.RETURN,"CLNNFND")
QUIT 0
+6 MERGE RETURN=DATA
+7 SET RETURN=1
+8 QUIT 1
+9 ;
+10 ;LSTCLNS(RETURN,SEARCH,START,NUMBER) ; Return clinics filtered by name.
+11 ; N LST
+12 ; D LSTCLNS^MBAAMDA1(.LST,$G(SEARCH),.START,$G(NUMBER))
+13 ; D BLDLST^MBAAMAPI(.RETURN,.LST)
+14 ; Q 1
+15 ; ;
CLNRGHT(RETURN,CLN) ; Verifies (DUZ) user access to Clinic Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT
+1 NEW DATA,TXT
+2 SET RETURN=0
+3 DO GETCLN^MBAAMDA1(.DATA,CLN,1)
+4 IF DATA(2500)="Y"
Begin DoDot:1
+5 IF $DATA(DATA(2501,DUZ,.01))>0
SET RETURN=1
QUIT
+6 IF '$TEST
Begin DoDot:2
+7 SET RETURN=0
SET TXT(1)=DATA(.01)
SET TXT(2)=$CHAR(10)
+8 DO ERRX^MBAAAPIE(.RETURN,"CLNURGT",.TXT)
+9 SET RETURN("CLN")=DATA(.01)
End DoDot:2
End DoDot:1
QUIT RETURN
+10 IF '$TEST
SET RETURN=1
QUIT 1
+11 ;
+12 ;CLNVSC(RETURN,SC) ; Verifies clinic stop code validation
+13 ; N DATA
+14 ; S RETURN=0
+15 ; D GETCSC^MBAAMDA1(.DATA,+SC)
+16 ; I $S('$D(DATA):1,'DATA(2):0,1:$G(DATA(2))'>DT) D Q RETURN
+17 ; . S TEXT(1)=+SC
+18 ; . D ERRX^MBAAAPIE(.RETURN,"CLNSCIN",.TEXT)
+19 ; . S RETURN=0
+20 ; S RETURN=1
+21 ; Q RETURN
+22 ;
GETSCAP(RETURN,SC,DFN,SD) ; Get clinic appointment Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT
+1 NEW NOD0,CO
+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(NOD0,U,11)
End DoDot:1
+15 QUIT 1
+16 ;
SLOTS(RETURN,SC) ; Get available slots MBAA RPC: MBAA GET CLINIC AVAILABILITY
+1 DO SLOTS^MBAAMDA2(.RETURN,SC)
+2 SET RETURN=1
+3 QUIT 1
+4 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+5 ;SCEXST(RETURN,CSC) ; Get Stop Cod Exception status
+6 ; N RET,LAST
+7 ; D SCEXST^MBAAMDA2(.RET,CSC)
+8 ; S RETURN=RET
+9 ; I RET>0 S LAST=99999999999,LAST=$O(RET("EFFECTIVE DATE",LAST),-1) D
+10 ; . M RETURN=RET("EFFECTIVE DATE",LAST)
+11 ; Q RETURN
+12 ; ;
LSTAPPT(RETURN,SEARCH,START,NUMBER) ; Lists appointment types MBAA RPC: MBAA APPOINTMENT LIST BY NAME
+1 NEW RET,DL,IN
+2 if '$DATA(START)
SET START=""
if '$DATA(SEARCH)
SET SEARCH=""
+3 if '$GET(NUMBER)
SET NUMBER=""
+4 SET RETURN=0
+5 ;ICR#: 10104 XLFSTR
DO LSTAPPT^MBAAMDA2(.RET,$$UP^XLFSTR(SEARCH),.START,NUMBER)
+6 SET RETURN(0)=RET("DILIST",0)
+7 SET DL="DILIST"
+8 FOR IN=1:1:$PIECE(RETURN(0),U,1)
Begin DoDot:1
+9 SET RETURN(IN)=""
+10 SET RETURN(IN,"ID")=RET(DL,2,IN)
+11 SET RETURN(IN,"NAME")=RET(DL,"ID",IN,".01")
End DoDot:1
+12 SET RETURN=1
+13 QUIT 1
+14 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+15 ;GETAPPT(RETURN,TYPE) ; Returns Appointment Type detail
+16 ; D GETAPPT^MBAAMDA2(.RETURN,TYPE,1,1,1)
+17 ; S RETURN=1
+18 ; Q 1
+19 ; ;
+20 ;GETELIG(RETURN,ELIG) ; Returns Eligibility Code detail
+21 ; D GETELIG^MBAAMDA2(.RETURN,ELIG,1,1,1)
+22 ; S RETURN=1
+23 ; Q 1
+24 ; ;
+25 ;GETPEND(RETURN,DFN,DT) ; Get pending appointments
+26 ; N CNT,SCAP,APP,CLN,%
+27 ; S CNT=""
+28 ; D GETPEND^MBAAMDA2(.APP,DFN,DT)
+29 ; F S CNT=$O(APP(CNT)) Q:CNT="" D
+30 ; . S RETURN(CNT,"COLLATERAL VISIT")=APP(CNT,13)
+31 ; . S RETURN(CNT,"APPOINTMENT TYPE")=$$APTYNAME^MBAAMDA2(APP(CNT,9.5))
+32 ; . S RETURN(CNT,"LAB")=APP(CNT,2)
+33 ; . S RETURN(CNT,"XRAY")=APP(CNT,3)
+34 ; . S RETURN(CNT,"EKG")=APP(CNT,4)
+35 ; . S %=$$GETCLN^MBAAMAP1(.CLN,APP(CNT,.01))
+36 ; . S RETURN(CNT,"CLINIC")=$P(CLN("NAME"),U,2)
+37 ; . S %=$$GETSCAP^MBAAMAP1(.SCAP,APP(CNT,.01),DFN,CNT)
+38 ; . S RETURN(CNT,"LENGTH OF APP'T")=$G(SCAP("LENGTH"))
+39 ; . S RETURN(CNT,"CONSULT LINK")=$G(SCAP("CONSULT"))
+40 ; S RETURN=($D(RETURN)>0)
+41 ; Q 1
+42 ; ;
+43 ;GETAPTS(RETURN,DFN,SD) ; Get patient appointments
+44 ; S DFN=+DFN
+45 ; D GETAPTS^MBAAMDA2(.RETURN,+DFN,.SD)
+46 ; S RETURN=($D(RETURN)>0)
+47 ; Q 1
+48 ; ;
LSTCRSNS(RETURN,SEARCH,START,NUMBER) ; MBAA RPC: MBAA LIST CANCELLATION REASONS
+1 NEW LST
+2 MERGE LST=RETURN
+3 DO LSTCRSNS^MBAAMDA2(.LST,$$UP^XLFSTR($GET(SEARCH)),.START,$GET(NUMBER))
+4 DO BLDLST^MBAAMAPI(.RETURN,.LST)
+5 QUIT RETURN
+6 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+7 ;FRSTAVBL(RETURN,SC) ; Get first available date
+8 ; D FRSTAVBL^MBAAMDA2(.RETURN,SC)
+9 ; Q 1
+10 ; ;
+11 ;linetag LSTCAPTS is removed, it is not needed until the next enhancement of MBAA
+12 ;LSTCAPTS(RETURN,SC,SDBEG,SDEND,STAT) ; Returns clinic appointments filtered by date and status
+13 ;N APTS,CNT,IND,FAPTS,GROUPS
+14 ;S CNT=0,IND=0
+15 ;S RETURN=0
+16 ;D GROUP^SDAM($P(STAT,U),.GROUPS)
+17 ;D LSTCAPTS^MBAAMDA1(.APTS,SC,.SDBEG,.SDEND)
+18 ;D BLDAPTS(.RETURN,.APTS,SC,,.GROUPS)
+19 ;S RETURN=1
+20 ;Q 1
+21 ;
+22 ;linetag LSTPAPTS is removed, this functionality is not needed until a future enhancement of MBAA
+23 ;LSTPAPTS(RETURN,DFN,SDBEG,SDEND,STAT) ; Returns patient appointments filtered by date and status
+24 ;N APTS,CNT,IND,FAPTS,GROUPS
+25 ;S CNT=0,IND=0
+26 ;S RETURN=0
+27 ;D GROUP^SDAM($P(STAT,U),.GROUPS)
+28 ;D LSTPAPTS^MBAAMDA1(.APTS,DFN,.SDBEG,.SDEND)
+29 ;D BLDAPTS(.RETURN,.APTS,,DFN,.GROUPS)
+30 ;S RETURN=1
+31 ;Q 1
+32 ;
+33 ;linetag BLDAPTS is removed, it is not needed until the next enhancement of MBAA
+34 ;BLDAPTS(RETURN,APTS,SSC,SDFN,GROUPS) ; Build appointment list
+35 ;N IND,DFN,SC,VA,VADM,CDATA,SDATA,SDDA,SDSTAT,CAPT,PAPT
+36 ;F IND=0:0 S IND=$O(APTS(IND)) Q:IND="" D
+37 ;. S SDATA=APTS(IND,"SDATA")
+38 ;. Q:'$G(SDFN)&($P(SDATA,U,2)["C")
+39 ;. S DFN=$S('$G(SDFN):+APTS(IND,"CDATA"),1:SDFN)
+40 ;. S SD=APTS(IND,"SD")
+41 ;. S SC=$S('$G(SSC):APTS(IND,"SC"),1:SSC)
+42 ;. S SDDA=APTS(IND,"SDDA")
+43 ;. S CDATA=$G(APTS(IND,"CDATA"))
+44 ;. S SDSTAT=$$STATUS^SDAM1(DFN,SD,SC,SDATA,$S($D(SDDA):SDDA,1:""))
+45 ;. Q:'$$CHK^SDAM1(,,,,.GROUPS,SDSTAT)
+46 ;. Q:$G(SSC)&(($P(CDATA,U,9)="C")!($P(SDATA,U,2)["C")&($G(SC)))
+47 ;. S CNT=CNT+1
+48 ;. D 2^VADPT
+49 ;. S RETURN(CNT,"BID")=VA("BID")
+50 ;. S RETURN(CNT,"NAME")=VADM(1)
+51 ;. D GETPAPT^MBAAMDA4(.PAPT,DFN,SD)
+52 ;. S RETURN(CNT,"GAF")=$$GAFREQ(DFN,SC,$P(SDATA,U,11))
+53 ;. S RETURN(CNT,"SD")=SD
+54 ;. S RETURN(CNT,"STAT")=SDSTAT
+55 ;. S RETURN(CNT,"STATI")=PAPT(3,"I")
+56 ;. S RETURN(CNT,"OE")=PAPT(21,"I")
+57 ;. S RETURN(CNT,"DFN")=DFN
+58 ;. S RETURN(CNT,"LAB")=$P(SDATA,U,3)
+59 ;. S RETURN(CNT,"XRAY")=$P(SDATA,U,4)
+60 ;. S RETURN(CNT,"EKG")=$P(SDATA,U,5)
+61 ;. S RETURN(CNT,"SC")=SC
+62 ;. D GETCAPT^MBAAMDA4(.CAPT,DFN,SD)
+63 ;. S RETURN(CNT,"LEN")=CAPT(1)
+64 ;. S RETURN(CNT,"CLINIC")=PAPT(.01,"E")
+65 ;. S RETURN(CNT,"SDDA")=APTS(IND,"SDDA")
+66 ;. S:$G(APTS(IND,"CONS"))>0 RETURN(CNT,"CSTAT")=$$CNSSTAT^MBAAMEXT(APTS(IND,"CONS"))
+67 ;Q
+68 ;
+69 ;GAFREQ(DFN,SC,CVSIT) ;
+70 ; N SDELIG,SDGAF,SDGAFST
+71 ; S SDELIG=$$ELSTAT^SDUTL2(DFN)
+72 ; I $$MHCLIN^SDUTL2(SC),'($$COLLAT^SDUTL2(SDELIG)!$G(CVSIT)) D Q SDGAFST
+73 ; . S SDGAF=$$NEWGAF^SDUTL2(DFN),SDGAFST=$P(SDGAF,"^") Q
+74 ; Q 0
+75 ; ;
+76 ;GETCSC(RETURN,SC) ; Get clinic stop code
+77 ; N CLN
+78 ; D GETCLN^MBAAMDA1(.CLN,SC,1)
+79 ; D GETCSC^MBAAMDA1(.RETURN,$G(CLN(8)))
+80 ; S RETURN=1
+81 ; Q 1
+82 ; ;
CPAIR(RETURN,SC) ;Validate primary stop code, get credit pair MBAA RPC: MBAA APPOINTMENT MAKE
+1 ;Input: SC=HOSPITAL LOCATION record IFN
+2 ;Input: RETURN=variable to return clinic credit pair (pass by reference)
+3 ;Output: 1=success, 0=invalid primary stop code
+4 ;WCJ;MBAA*1*7; Newed CLN & CS
NEW SDSSC,CLN,CS
+5 DO GETCLN^MBAAMDA1(.CLN,SC,1)
+6 if '$GET(CLN(8))
QUIT 0
+7 DO GETCSC^MBAAMDA1(.CS,CLN(8))
+8 SET RETURN=$GET(CS(1))
SET RETURN=$SELECT(RETURN<100:0,RETURN>999:0,1:RETURN)
+9 if RETURN'>0
QUIT 0
+10 KILL CS
DO GETCSC^MBAAMDA1(.CS,CLN(2503))
+11 SET SDSSC=$GET(CS(1))
SET RETURN=RETURN_$SELECT(SDSSC<100:"000",SDSSC>999:"000",1:SDSSC)
+12 QUIT 1
+13 ;
PTFU(RETURN,DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months)
+1 ;Input: DFN=patient ifn
+2 ;Input: SC=clinic ifn
+3 ;Output: '1' if seen within 24 months, '0' otherwise
+4 ;
+5 ;variable check
if 'DFN!'SC
QUIT 0
+6 NEW SDBDT,SDT,SDX,SDY,SDCP1,SDCP2,SDENC,SDCT
+7 ;set up variables
+8 SET SDBDT=(DT-20000)+.24
SET SDT=DT_.999999
SET SDY=0
+9 ;get credit pair for this clinic
SET SDX=$$CPAIR(.SDCP1,SC)
+10 if 'SDX
QUIT 0
+11 ;Iterate through encounters
+12 FOR
SET SDT=$ORDER(^SCE("ADFN",DFN,SDT),-1)
if (SDT<SDBDT)!SDY
QUIT
Begin DoDot:1
+13 SET SDENC=0
FOR
SET SDENC=$ORDER(^SCE("ADFN",DFN,SDT,SDENC))
if 'SDENC!SDY
QUIT
Begin DoDot:2
+14 ;parent encounters only
if $$GET1^DIQ(409.68,SDENC,.06,"I")
QUIT
+15 ;get clinic
SET SDX=$$GET1^DIQ(409.68,SDENC,.04,"I")
+16 if 'SDX
QUIT
+17 ;get credit pair for this clinic
SET SDX=$$CPAIR(.SDCP2,SDX)
+18 if 'SDX
QUIT
+19 ;compare credit pairs
SET SDY=SDCP1=SDCP2
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT SDY
+23 ;
+24 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+25 ;HASPEND(RETURN,DFN,DT) ; Check if patient has panding appointments
+26 ; D HASPEND^MBAAMDA2(.RETURN,DFN,DT)
+27 ; Q 1
+28 ; ;
+29 ;LSTSRT(RETURN) ;List scheduling request types
+30 ; K RETURN
+31 ; S RETURN=1
+32 ; D LSTSCOD^MBAAMDAL(2.98,25,.RETURN)
+33 ; Q 1
+34 ; ;
+35 ;LSTAPPST(RETURN) ;List appointment statuses
+36 ; K RETURN
+37 ; S RETURN=1
+38 ; D LSTSCOD^MBAAMDAL(2.98,3,.RETURN)
+39 ; Q 1
+40 ; ;
+41 ;LSTHLTP(RETURN) ;List hospital location types
+42 ; K RETURN
+43 ; S RETURN=1
+44 ; D LSTSCOD^MBAAMDAL(44,2,.RETURN)
+45 ; Q 1
+46 ;
+47 ;
+48 ;WCJ;MAAA*1*7;old PTFU tag saved for posterity
+49 ;deemed too slow since it goes through the entire outpatient encounter file
+50 ;and while it uses a screen, it was still way too slow
+51 ;
PTFU2(RETURN,DFN,SC) ;Determine if this is a follow-up (return to clinic within 24 months) Called by RPC MBAA APPOINTMENT MAKE
+1 ;Input: DFN=patient ifn
+2 ;Input: SC=clinic ifn
+3 ;Output: '1' if seen within 24 months, '0' otherwise
+4 ;
+5 ;variable check
if 'DFN!'SC
QUIT 0
+6 SET RETURN=1
+7 NEW SDBDT,SDT,SDX,SDY,SDZ,SDCP,SDCP1,SC0,SDENC,SDCT,LST,ENC,FLDS
+8 ;set up variables
+9 SET SDBDT=(DT-20000)+.24
SET SDT=DT_.999999
SET SDY=0
+10 ;get credit pair for this clinic
SET SDX=$$CPAIR(.SDCP,SC)
+11 ;Iterate through encounters
+12 DO LSTAENC^MBAAMDA1(.LST,DFN)
+13 SET FLDS(.04)="CLINIC"
SET FLDS(.06)="PARENT"
+14 DO BLDLST^MBAAMAPI(.ENC,.LST,.FLDS)
+15 FOR
SET SDT=$ORDER(ENC(SDT),-1)
if 'SDT!SDY
QUIT
Begin DoDot:1
+16 ;parent encounters only
if ENC(SDT,"PARENT")]""
QUIT
+17 if ENC(SDT,"NAME")<SDBDT
QUIT
+18 ;get credit pair for encounter
SET SDX=$$CPAIR(.SDCP1,ENC(SDT,"CLINIC"))
+19 ;compare credit pairs
SET SDY=SDCP=SDCP1
+20 QUIT
End DoDot:1
+21 QUIT SDY
