- MBAARPC2 ;OIT-PD/PB - Scheduling RPCs ;FEB 23, 2017
- ;;1.0;Scheduling Calendar View;**1,4,5,7**;Feb 13, 2015;Build 16
- ;
- ;This routine has multiple RPCs created to support the mobile Scheduling apps
- ;
- ;Associated ICRs:
- ; ICR#
- ; 10103 XLFDT
- ; 5838 SDAMEVT
- ; 6048 SDAMEVT
- ; 6053 DPT
- ; 4433 SDAMA301
- ;
- ;Cancel an Appointment
- CANCEL(RV,DFN,SC,SD,TYPE,RSN,RMK) ; SD APPOINTMENT CANCEL
- ; MBAA RPC: MBAA CANCEL APPOINTMENT
- N STATUS,RESULT
- S STATUS=$$CANCEL1(.RESULT,DFN,SC,SD,TYPE,RSN,RMK)
- ;D MERGE^MBAAMRPC(.RV,.RESULT)
- S RV=$G(RESULT(0)) ; MBAA*1*5 - Return error text with error code
- Q
- CANCEL1(RETURN,DFN,SC,SD,TYP,RSN,RMK) ; Cancel appointment MBAA RPC: MBAA CANCEL APPOINTMENT
- N CDATE,CDT,ERR,ODT,OIFN,OUSR,%
- N CAPT,CIFN ;alb/sat 4 - existing variables need to be Newed
- S RETURN=0
- S %=$$CHKCAN(.RETURN,DFN,SC,SD) I $E(%,1,3)="APT" Q RETURN
- S CDATE=$$NOW^XLFDT ;ICR#: 10103 XLFDT
- S %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
- S CIFN=CAPT("IFN")
- S OUSR=CAPT("USER"),ODT=CAPT("DATE")
- N SDATA,SDCPHDL
- S SDCPHDL=$$HANDLE^SDAMEVT(1) ;ICR#: 5838 SDAMEVT
- D BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCPHDL)
- S CDT=$$NOW^XLFDT() ;ICR#: 10103 XLFDT
- D CANCEL^MBAAMDA3(.ERR,DFN,SD,TYP,RSN,RMK,$E(CDT,1,12),DUZ,OUSR,ODT)
- S OIFN=$$COVERB^MBAAMDA1(SC,SD,CIFN)
- S %=$$CANCEL^MBAAAPI1(RETURN,CAPT("CONSULT"),SC,SD,CIFN,RMK,TYP)
- D CANCEL^MBAAMDA1(SC,SD,DFN,CIFN)
- ;alb/sat 4 - begin mod to update SDEC
- N SDECAPPT
- S SDECAPPT=$$APPTGET^SDECUTL(DFN,SD,SC)
- D:+SDECAPPT SDECCAN^SDEC08(SDECAPPT,"PC",RSN,RMK,"",DUZ,"01")
- ;alb/sat 4 - end mod
- D CANCEL^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,0,SDCPHDL) ;ICR#: 6048 MBAA SDAMEVT API CALLS
- S RETURN=1
- Q RETURN
- ;
- CHKCAN(RETURN,DFN,SC,SD) ; Verify cancel MBAA RPC: MBAA CANCEL APPOINTMENT
- ;N APT,RET,%
- K APT N RET,TXT,% ;alb/sat 4 - existing TXT needs to be Newed
- S RETURN=0
- I '$D(^DPT(DFN,"S",SD)) S RETURN="APTNTSCH" Q RETURN ; patient doesn't have an appointment at the requested time ;ICR#: 6053 DPT
- ;
- D GETAPTS^MBAAMDA2(.APT,DFN,.SD)
- ;
- I APT("APT",SD,"STATUS")["C" D S RETURN="APTCAND" Q RETURN ; Appointment already canceled.
- . D ERRX^MBAAAPIE(.RETURN,"APTCAND")
- ;
- I $$ISAPTCO^MBAAMAP4(,DFN,SD) D S RETURN="APTCCHO" Q RETURN ; Appointment has a check out date and can't be canceled - MBAA*1*5
- . D ERRX^MBAAAPIE(.RETURN,"APTCCHO")
- ;
- S %=$$CLNRGHT^MBAAMAP1(.RET,+SC)
- I RET=0 D S RETURN="APTCRGT" Q RETURN ; Appointment not cancelled. Access to this clinic to this clinic is restricted to only priv. users - MBAA*1*5
- . S TXT(1)=RET("CLN"),TXT(2)=$C(10)
- . D ERRX^MBAAAPIE(.RETURN,"APTCRGT",.TXT)
- ;
- I '$$CHKSPC(.STAT,DFN,SD) D S RETURN="APTCNPE" Q RETURN ; This appointment can't be canceled - MBAA*1*5
- . D ERRX^MBAAAPIE(.RETURN,"APTCNPE",.TXT)
- ;
- ; OK if you made it this far
- S RETURN=1
- ;
- Q RETURN
- ;
- CHKSPC(RETURN,DFN,SD) ; Check if status permit cancelation, MBAA RPC: MBAA CANCEL APPOINTMENT
- ;INPUT: RETURN -Looks like flag of 1 or 0 is RETURNed here and by the function
- ; DFN - Patient IEN
- ; SD - Date/Time of appointment
- N APT0,STATUS,IND,STAT,STATS
- S RETURN=0
- ;
- ; get appointment 0 node
- S APT0=$$GETAPT0^MBAAMDA2(DFN,SD)
- ;
- ;T13 Change to use SDAMA301 API
- K R1 D STATUS^MBAARPC1(.R1,DFN,SD,+$G(APT0)) S STATUS=+R1 K R1 ;ICR 4433
- ;S STATUS=+$$STATUS^SDAM1(DFN,SD,+$G(APT0),$G(APT0)) ;ICR#: 2851 MBAA ACCESS TO SDAM1 API get appointment status
- D LSTCSTA1^MBAAMDA2(.STAT)
- D BLDLST^MBAAMAPI(.STATS,.STAT)
- S IND=0
- F S IND=$O(STATS(IND)) Q:IND=""!(RETURN=1) D
- . I STATS(IND,"ID")=STATUS S RETURN=1 Q
- ;
- S RETURN=$G(RETURN)
- Q RETURN
- ;
- ;Line Tags CLNDATA, RECALL, DELETE, CHK, NEWEWL, WFCK, ENRCHK, REQBY is commented out due to the functionality being descoped from the first release
- ;CLNDATA(RETURN,CLINICID) ; returns additional clinic data MBAA ADDITIONAL CLINIC DETAILS
- ; Input: CLINICID - IEN for the Clinic in the Hospital Location file (#44)
- ; Returns:
- ; If Successful:
- ; RETURN(0)="TREATING SPECIALTY^STOP CODE^CREDIT STOP CODE^SPECIALTY"
- ; If Failure:
- ; RETURN(0)="0^Missing CLINICID"
- ; RETURN(0)="0^Clinic doesn't exist."
- ;
- ;I $G(CLINICID)="" S RETURN(0)="0^Missing CLINICID" Q
- ;I '$D(^SC(CLINICID,0)) S RETURN(0)="0^Clinic doesn't exist." Q ;ICR#: 6044
- ;I $P(^SC(CLINICID,0),"^",3)'="C" S RETURN(0)="0^Clinic doesn't exist." Q ;ICR#: 6044
- ;N NODE,STOPPTR,SPECPTR,CREDITPRT,SPECLTY,SPECL,SPEC,SPEC2,STOPCODE,CREDIT,CREDITPTR,CLINIC1,SPEC1 ;IRC#: 6044
- ;S NODE=$G(^SC(CLINICID,0)),STOPPTR=$P(NODE,"^",7),SPECPTR=$P(NODE,"^",20),CREDITPTR=$P(NODE,"^",18)
- ;S STOPCODE=$P(^DIC(40.7,STOPPTR,0),"^"),CREDIT=$P(^DIC(40.7,CREDITPTR,0),"^"),SPEC=$P(^DIC(45.7,SPECPTR,0),"^") ;ICR#: 1024, 362
- ;S SPECLTY=$P(^DIC(45.7,SPECPTR,0),"^",2),SPECL=$P(^DIC(42.4,SPECLTY,0),"^",1) ;ICR#: 430, 362
- ;D GETS^DIQ(44,CLINICID,"8;9.5;2503","IE","CLINIC1")
- ;S SPEC=$G(CLINIC1(44,CLINICID_",",9.5,"I")),STOPCODE=$G(CLINIC1(44,CLINICID_",",8,"E")),CREDIT=$G(CLINIC1(44,CLINICID_",",2503,"E")),SPEC2=$G(CLINIC1(44,CLINICID_",",9.5,"E"))
- ;D GETS^DIQ(45.7,SPEC,".01;1","IE","SPEC1")
- ;S SPECL=$G(SPEC1(45.7,SPEC_",",1,"E"))
- ;S RETURN(0)=$G(SPEC2)_"^"_$G(STOPCODE)_"^"_$G(CREDIT)_"^"_$G(SPECL)
- ;K NODE,STOPPTR,SPECPTR,CREDITPRT,SPECLTY,SPECL,SPEC,STOPCODE,CREDIT,CREDITPTR,CLINIC1,SPEC1
- ;Q
- ;RECALL(RESULTS,DFN,CLINIC,RECALLDT,PTRECDT,PROVIDER,LEN,FAST,TEST,USER,COMMENT) ; adds new patients to the Recall List MBAA RPC: MBAA ADD TO RECALL LIST
- ; Input parameter is the Patient DFN
- ;S RESULTS(0)=1
- ;I $G(DFN)="" S RESULTS(0)="0^DFN is not defined" Q
- ;T13 Change to FM read
- ;N JX S JX=$$GET1^DIQ(2,$G(DFN),.01) I $G(JX)="" S RESULTS(0)="0^Not a patient in this system." Q ;ICR#: 6053 DPT
- ;I '$D(^DPT(DFN,0)) S RESULTS(0)="0^Not a patient in this system." Q ;ICR#: 6053 DPT
- ;I $G(CLINIC)="" S RESULTS(0)="0^Clinic not provided." Q
- ;T13 Change to FM read
- ;I '$D(^SC(CLINIC,0)) S RESULTS(0)="0^Clinic not in the Hospital Location File." Q ;ICR#: 6044
- ;N JX S JX=$$GET1^DIQ(44,$G(CLINIC),.01) I $G(JX)="" S RESULTS(0)="0^Clinic not in the Hospital Location File." Q ;ICR#: 6044
- ;I ($G(RECALLDT)=""!($G(RECALLDT)'>DT)) S RESULTS(0)="0^Provider Recall date not provided or not a valid date. Date must be in the future." Q
- ;I ($G(PTRECDT)=""!($G(PTRECDT)'>DT)) S RESULTS(0)="0^Patient recall date not provided or not a valid date. Date must be in the future" Q
- ;I $G(PROVIDER)="" S RESULTS(0)="0^Provider IEN not provided." Q
- ;I '$D(^VA(200,$G(PROVIDER),0)) S RESULTS(0)="0^Provider not provided." Q
- ;N JX S JX=$$GET1^DIQ(200,$G(PROVIDER),.01) I $G(JX)="" S RESULTS(0)="0^Provider not in the New Person file." Q ;ICR#: 713 VA(200
- ;I $G(LEN)'>0 S RESULTS(0)="0^Appointment length not provided." Q
- ;I $G(FAST)="" S RESULTS(0)="0^FAST code not provided." Q
- ;S FAST=$$LOW^XLFSTR($G(FAST))
- ;I "nf"'[FAST S RESULTS(0)="0^FAST code not provided." Q
- ;I $G(TEST)'>0 S RESULTS(0)="0^Appointment Type code not provided. Appointment Type is a numeric value." Q
- ;I $G(USER)'>0 S RESULTS(0)="0^User IEN not provided." Q
- ;I '$D(^VA(200,$G(USER),0)) S RESULTS(0)="0^User IEN not provided." Q
- ;N JX S JX=$$GET1^DIQ(200,$G(USER),.01) I $G(JX)="" S RESULTS(0)="0^User not in the New Person File." Q ;ICR#: 713 VA(200
- ;S ERR=0 D CHK I ERR=1 S RESULTS(0)="0^Duplicate Recall List Entry" Q
- ;K DO S (DIC,DIE)="^SD(403.5,",DIC(0)="Z",X=DFN,DLAYGO=403.5 D FILE^DICN K DO S NUM=+Y ;ICR#: 6045 SD(403.5
- ;S DA=NUM,DR="4.5///"_$G(CLINIC)_";4///"_$G(PROVIDER)_";2.6///"_$G(FAST)_";4.7///"_$G(LEN)_";5///"_$G(RECALLDT)_";5.5///"_$G(PTRECDT)_";2.5///"_$G(COMMENT)_";3///"_$G(TEST)_";7///"_$G(USER)
- ;D ^DIE
- ;S DA=NUM,DR="[SDRR RECALL CARD ADD]",DIE("NO^")="Not Allowed" D ^DIE
- ;I $D(DTOUT) D DELETE
- ;K DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,DIR,DTOUT
- ;Q
- ;DELETE ;delete new incomplete record and display message MBAA RPC: MBAA ADD TO RECALL LIST
- ;S DIK=DIE
- ;D ^DIK K DIK
- ;S RESULTS(0)="0^All required data was not provided. Recall was not created!"
- ;Q
- ;CHK ; checks to see if the patient is on the recall list for the clinic and provider date MBAA RPC: MBAA ADD TO RECALL LIST
- ;S XX=0 F S XX=$O(^SD(403.5,"B",DFN,XX)) Q:XX'>0 D ;ICR#: 6045 SD(403.5
- ;.;T13 Change to use FM
- ;.N ARRAY,ERR,C1,RD1,P1 D GETS^DIQ(403.5,XX_",","2;4,5","I","ARRAY","ERR") ;ICR#: 6045 SD(403.5
- ;.S C1=$G(ARRAY(403.5,XX_",",2,"I")),RD1=$G(ARRAY(403.5,XX_",",5,"I")),P1=$G(ARRAY(403.5,XX_",",4,"I"))
- ;.I $G(C1)=CLINIC&($G(RD1)=RECALLDT)&($G(P1)=PROVIDER) S ERR=1
- ;.;S NODE=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
- ;.;I ($P(NODE,"^",2)=CLINIC&($P(NODE,"^",6)=RECALLDT)&($P(NODE,"^",5)=PROVIDER)) S ERR=1
- ;I $G(ERR)>0 S ERR=1
- ;Q
- ;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
- ;CLNRGHT(RV,CLN) ;
- ; N STATUS,RESULT S STATUS=$$CLNRGHT^MBAAMAP1(.RESULT,CLN)
- ; ;D MERGE^MBAAMRPC(.RV,.RESULT)
- ; S RV(0)=$G(RESULT)
- ; Q
- NEWEWL(RV,SDWLD) ; ZLV EWL NEW
- N Y ;alb/sat 4 - existing Y needs to be Newed
- I $G(SDWLD)="" S RV(0)="0^SDWLD List missing." Q
- S SDWLD("WLTYPE")=$P($G(SDWLD),"^",1)
- I SDWLD("WLTYPE")="" S RV(0)="0^INVPARAM WLTYPE IS NULL" Q
- I $G(SDWLD("WLTYPE"))'>0!($G(SDWLD("WLTYPE"))'<5) S RV(0)="0^INVPARAM WLTYPE" Q
- S SDWLD("PATIENT")=$P($G(SDWLD),"^",2)
- I SDWLD("PATIENT")="" S RV(0)="0^INVPARAM PATIENT IS NULL" Q
- S DFN=$G(SDWLD("PATIENT")) I '$D(^DPT(DFN,0)) S RV(0)="0^INVPARAM PATIENT DOESN'T EXIST." K DFN Q ;ICR#: 6053 DPT
- S SDWLD("INSTITUTION")=$P($G(SDWLD),"^",3)
- I SDWLD("INSTITUTION")="" S RV(0)="0^INVPARAM INSTITUTION IS NULL" Q
- N SITE S X=$G(SDWLD("INSTITUTION")) S SITE=$$IEN^XUMF(4,,X) I +$G(SITE)'>0 S RV(0)="0^INVPARAM INVALID INSTITUTION NUMBER." Q ;ICR#:3795 XUMF
- S SDWLD("WAITFOR")=$P($G(SDWLD),"^",4)
- I SDWLD("WAITFOR")="" S RV(0)="0^INVPARAM WAITFOR IS NULL" Q
- ;S ERR=0 D WFCK Q:$G(ERR)>0
- S SDWLD("PRIORITY")=$P($G(SDWLD),"^",5)
- I SDWLD("PRIORITY")="" S RV(0)="0^INVPARAM PRIORITY IS NULL" Q
- I SDWLD("PRIORITY")'="A",(SDWLD("PRIORITY")'="F") S RV(0)="0^INVPARAM INVALID PRIORITY" Q
- S SDWLD("REQBY")=$P($G(SDWLD),"^",6)
- D REQBY
- Q:$G(ERR)=1
- S SDWLD("PROVIDER")=$P($G(SDWLD),"^",7)
- I SDWLD("PROVIDER")'="" D
- .N IEN S ERR=0,IEN=$G(SDWLD("PROVIDER"))
- .N JX S JX=$$GET1^DIQ(200,$G(IEN),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM PROVIDER IS NOT IN THE NEW PERSON FILE" Q ;ICR#: 713 VA(200
- .;I '$D(^VA(200,IEN,0)) S ERR=1,RV(0)="0^INVPARAM PROVIDER IS NOT IN THE NEW PERSON FILE" Q ;ICR#: 713 VA(200
- .I '$D(^XUSEC("PROVIDER",IEN)) S ERR=1,RV(0)="0^INVPARAM NOT A PROVIDER" Q ;ICR#: 10076 XUSEC
- Q:$G(ERR)=1
- S SDWLD("SCPRCNT")=$P($G(SDWLD),"^",8)
- I SDWLD("SCPRCNT")'="" D
- .S ERR=0 I SDWLD("SCPRCNT")'>0!(SDWLD("SCPRCNT")'<101) S ERR=1,RV(0)="0^INVPARAM SERVICE CONNECTED PERCENTAGE" Q
- Q:$G(ERR)=1
- S SDWLD("SCPRIORITY")=$P($G(SDWLD),"^",9)
- I SDWLD("SCPRIORITY")'="" D
- .S ERR=0 I $G(SDWLD("SCPRIORITY"))'=0,($G(SDWLD("SCPRIORITY"))'=1) S ERR=1,RV(0)="0^INVPARAM INVALID PRIORITY" Q
- Q:$G(ERR)=1
- S SDWLD("DSRDDT")=$P($G(SDWLD),"^",10)
- I SDWLD("DSRDDT")="" S RV(0)="0^INVPARAM DESIRED DATE OF APPOINTMENT IS NULL" Q
- S ERR=0,X=$G(SDWLD("DSRDDT")) D ^%DT I Y=-1 S ERR=0,RV(0)="0^INVPARAM NOT A VALID DATE" Q
- Q:$G(ERR)=1
- S SDWLD("CMNTS")=$P($G(SDWLD),"^",11)
- I SDWLD("CMNTS")'="" D
- .I $L($G(SDWLD("CMNTS")))'>0!($L($G(SDWLD("CMNTS")))'<61) S ERR=1,RV(0)="0^INVPARAM COMMENTS ARE TOO LONG" Q
- Q:$G(ERR)=1
- S SDWLD("ENRSTAT")=$P($G(SDWLD),"^",12)
- I SDWLD("ENRSTAT")="" S RV(0)="0^INVPARAM ENROLLEE STATUS IS NULL" Q
- S ERR=0 D ENRCHK Q:$G(ERR)=1
- S SDWLD("ENRDU")=$P($G(SDWLD),"^",13)
- I SDWLD("ENRDU")'="" D
- .S ERR=0 S X=$G(SDWLD("ENRDU")) D ^%DT I $G(Y)=-1 S ERR=1,RV(0)="0^INVPARAM ENROLLEE DATE INVALID DATE" Q
- Q:$G(ERR)=1
- S SDWLD("ENRDF")=$P($G(SDWLD),"^",14)
- I SDWLD("ENRDF")'="" D
- .S ERR=0 I $G(SDWLD("ENRDF"))'=0,($G(SDWLD("ENRDF"))'<5) S ERR=1,RV(0)="0^INVPARAM ENROLLEE DATABASE FILE" Q
- Q:ERR=1
- S SDWLD("TICKLER")=$P($G(SDWLD),"^",15)
- I SDWLD("TICKLER")'="" D
- .S SDWLD("TICKLER")=$$UP^XLFSTR($G(SDWLD("TICKLER")))
- .S ERR=0 I $G(SDWLD("TICKLER"))'="Y" S ERR=1,RV(0)="0^INVPARAM TICKLER" Q
- Q:ERR=1
- S SDWLD("CHDCLINP")=$P($G(SDWLD),"^",16)
- I SDWLD("CHDCLINP")'="" D
- .N APTR
- .S ERR=0,PTR=$G(SDWLD("CHDCLINP")) I '$D(^SDWL(409.3,PTR,0)) S ERR=1,RV(0)="0^INVPARAM CHANGED CLINIC PARENT POINTER IS NOT VALID" Q ;ICR#: 6046 SDWL(409.3
- .;T13 Change to use FM
- .I $D(^SDWL(409.3,PTR,0)) S APTR=$$GET1^DIQ(409.3,PTR_",",".01","I") I APTR'=SDWLD("PATIENT") S ERR=1,RV(0)="0^INVPARAM CHANGED CLINIC PARENT POINTER IS FOR A DIFFERENT PATIENT" Q ;ICR#: 6046 SDWL(409.3
- .;I $D(^SDWL(409.3,PTR,0)) S APTR=$P(^SDWL(409.3,PTR,0),"^",1) I APTR'=SDWLD("PATIENT") S ERR=1,RV(0)="0^INVPARAM CHANGED CLINIC PARENT POINTER IS FOR A DIFFERENT PATIENT" Q ;ICR#: 6046 SDWL(409.3
- .K APTR
- Q:ERR=1
- I SDWLD("WLTYPE")=3!(SDWLD("WLTYPE")=4) D
- .K ERR S ERR=0
- .I SDWLD("REQBY")'=1,$G(SDWLD("REQBY"))'=2 S ERR=1
- I ERR=1 K ERR S RV(0)="0^INVPARAM REQBY" Q
- N STATUS,RESULT S STATUS=$$NEW^MBAAWLAP(.RESULT,.SDWLD)
- I 'STATUS S RV=-1
- I $G(STATUS) S RV(0)=1
- K ERR,X,IEN,DFN,PTR,CHK,TYPE,REQBY
- Q
- ;WFCK ; Check to make sure the pointer is valid for the Waitfor parameter
- ;N PTR S PTR=$G(SDWLD("WAITFOR")),ERR=0
- ;I SDWLD("WLTYPE")=1 D
- ;.;I '$D(^SCTM(404.51,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID TEAM" Q ;ICR#: 1945 DBIA 1945
- ;.N JX S JX=$$GET1^DIQ(404.51,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID TEAM" Q ;ICR#: 1945 DBIA 1945
- ;Q:$G(ERR)>0
- ;I SDWLD("WLTYPE")=2 D
- ;.;I '$D(^SCTM(404.57,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID POSITION" Q ;ICR#: 6064 MBAA ACCESS TO SCTM(404.57
- ;.N JX S JX=$$GET1^DIQ(404.57,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID POSITION" Q ;ICR#: 6064 MBAA ACCESS TO SCTM(404.57
- ;Q:$G(ERR)>0
- ;I SDWLD("WLTYPE")=3 D
- ;.;I '$D(^SDWL(409.31,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID SPECIALTY" Q ;ICR#: 6046 SDWL(409.3
- ;.N JX S JX=$$GET1^DIQ(409.31,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID SPECIALTY" Q ;ICR#: 6046 SDWL(409.3
- ;Q:$G(ERR)>0
- ;I SDWLD("WLTYPE")=4 D
- ;.;I '$D(^SDWL(409.32,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID WAIT LIST CLINIC" Q ;ICR#: 6046 SDWL(409.3
- ;.N JX S JX=$$GET1^DIQ(409.32,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID WAIT LIST CLINIC" Q ;ICR#: 6046 SDWL(409.3
- ;Q:$G(ERR)>0
- ;I SDWLD("WLTYPE")>5 S RV(0)="0^INVPARAM WAIT LIST TYPE" Q
- ;Q
- ENRCHK ; Check enrollee status codes - must be either N, E, P or U
- S CHK=$G(SDWLD("ENRSTAT"))
- I CHK'="N",(CHK'="E"),(CHK'="P"),(CHK'="U") S ERR=1,RV(0)="0^INVPARAM INVALID ENROLLEE STATUS" Q
- Q
- REQBY ; Checksto be sure a correct value for the REQBY parameter is correct based on the Wait List Type
- S ERR=0,TYPE=$G(SDWLD("WLTYPE")),REQBY=$G(SDWLD("REQBY"))
- I $G(REQBY)'=1,($G(REQBY)'=2),($G(REQBY)'="") S ERR=1,RV(0)="0^INVPARAM INVALID REQBY" Q
- I $G(REQBY)'="" D
- .I TYPE=3,(TYPE=4) D
- ..I REQBY'=1,(REQBY'=2) S ERR=1,RV(0)="0^INVPARAM INVALID REQBY" Q
- .I TYPE=1,(TYPE=2) D
- ..I REQBY=1,(REQBY'=2) S ERR=1,RV(0)="0^INVPARAM INVALID REQBY" Q
- I $G(REQBY)="" D
- .I TYPE'=1,(TYPE'=2) S ERR=1,RV(0)="0^INVPARAM INVALID REQBY" Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAARPC2 15266 printed Feb 18, 2025@23:41:11 Page 2
- MBAARPC2 ;OIT-PD/PB - Scheduling RPCs ;FEB 23, 2017
- +1 ;;1.0;Scheduling Calendar View;**1,4,5,7**;Feb 13, 2015;Build 16
- +2 ;
- +3 ;This routine has multiple RPCs created to support the mobile Scheduling apps
- +4 ;
- +5 ;Associated ICRs:
- +6 ; ICR#
- +7 ; 10103 XLFDT
- +8 ; 5838 SDAMEVT
- +9 ; 6048 SDAMEVT
- +10 ; 6053 DPT
- +11 ; 4433 SDAMA301
- +12 ;
- +13 ;Cancel an Appointment
- CANCEL(RV,DFN,SC,SD,TYPE,RSN,RMK) ; SD APPOINTMENT CANCEL
- +1 ; MBAA RPC: MBAA CANCEL APPOINTMENT
- +2 NEW STATUS,RESULT
- +3 SET STATUS=$$CANCEL1(.RESULT,DFN,SC,SD,TYPE,RSN,RMK)
- +4 ;D MERGE^MBAAMRPC(.RV,.RESULT)
- +5 ; MBAA*1*5 - Return error text with error code
- SET RV=$GET(RESULT(0))
- +6 QUIT
- CANCEL1(RETURN,DFN,SC,SD,TYP,RSN,RMK) ; Cancel appointment MBAA RPC: MBAA CANCEL APPOINTMENT
- +1 NEW CDATE,CDT,ERR,ODT,OIFN,OUSR,%
- +2 ;alb/sat 4 - existing variables need to be Newed
- NEW CAPT,CIFN
- +3 SET RETURN=0
- +4 SET %=$$CHKCAN(.RETURN,DFN,SC,SD)
- IF $EXTRACT(%,1,3)="APT"
- QUIT RETURN
- +5 ;ICR#: 10103 XLFDT
- SET CDATE=$$NOW^XLFDT
- +6 SET %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
- +7 SET CIFN=CAPT("IFN")
- +8 SET OUSR=CAPT("USER")
- SET ODT=CAPT("DATE")
- +9 NEW SDATA,SDCPHDL
- +10 ;ICR#: 5838 SDAMEVT
- SET SDCPHDL=$$HANDLE^SDAMEVT(1)
- +11 DO BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCPHDL)
- +12 ;ICR#: 10103 XLFDT
- SET CDT=$$NOW^XLFDT()
- +13 DO CANCEL^MBAAMDA3(.ERR,DFN,SD,TYP,RSN,RMK,$EXTRACT(CDT,1,12),DUZ,OUSR,ODT)
- +14 SET OIFN=$$COVERB^MBAAMDA1(SC,SD,CIFN)
- +15 SET %=$$CANCEL^MBAAAPI1(RETURN,CAPT("CONSULT"),SC,SD,CIFN,RMK,TYP)
- +16 DO CANCEL^MBAAMDA1(SC,SD,DFN,CIFN)
- +17 ;alb/sat 4 - begin mod to update SDEC
- +18 NEW SDECAPPT
- +19 SET SDECAPPT=$$APPTGET^SDECUTL(DFN,SD,SC)
- +20 if +SDECAPPT
- DO SDECCAN^SDEC08(SDECAPPT,"PC",RSN,RMK,"",DUZ,"01")
- +21 ;alb/sat 4 - end mod
- +22 ;ICR#: 6048 MBAA SDAMEVT API CALLS
- DO CANCEL^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,0,SDCPHDL)
- +23 SET RETURN=1
- +24 QUIT RETURN
- +25 ;
- CHKCAN(RETURN,DFN,SC,SD) ; Verify cancel MBAA RPC: MBAA CANCEL APPOINTMENT
- +1 ;N APT,RET,%
- +2 ;alb/sat 4 - existing TXT needs to be Newed
- KILL APT
- NEW RET,TXT,%
- +3 SET RETURN=0
- +4 ; patient doesn't have an appointment at the requested time ;ICR#: 6053 DPT
- IF '$DATA(^DPT(DFN,"S",SD))
- SET RETURN="APTNTSCH"
- QUIT RETURN
- +5 ;
- +6 DO GETAPTS^MBAAMDA2(.APT,DFN,.SD)
- +7 ;
- +8 ; Appointment already canceled.
- IF APT("APT",SD,"STATUS")["C"
- Begin DoDot:1
- +9 DO ERRX^MBAAAPIE(.RETURN,"APTCAND")
- End DoDot:1
- SET RETURN="APTCAND"
- QUIT RETURN
- +10 ;
- +11 ; Appointment has a check out date and can't be canceled - MBAA*1*5
- IF $$ISAPTCO^MBAAMAP4(,DFN,SD)
- Begin DoDot:1
- +12 DO ERRX^MBAAAPIE(.RETURN,"APTCCHO")
- End DoDot:1
- SET RETURN="APTCCHO"
- QUIT RETURN
- +13 ;
- +14 SET %=$$CLNRGHT^MBAAMAP1(.RET,+SC)
- +15 ; Appointment not cancelled. Access to this clinic to this clinic is restricted to only priv. users - MBAA*1*5
- IF RET=0
- Begin DoDot:1
- +16 SET TXT(1)=RET("CLN")
- SET TXT(2)=$CHAR(10)
- +17 DO ERRX^MBAAAPIE(.RETURN,"APTCRGT",.TXT)
- End DoDot:1
- SET RETURN="APTCRGT"
- QUIT RETURN
- +18 ;
- +19 ; This appointment can't be canceled - MBAA*1*5
- IF '$$CHKSPC(.STAT,DFN,SD)
- Begin DoDot:1
- +20 DO ERRX^MBAAAPIE(.RETURN,"APTCNPE",.TXT)
- End DoDot:1
- SET RETURN="APTCNPE"
- QUIT RETURN
- +21 ;
- +22 ; OK if you made it this far
- +23 SET RETURN=1
- +24 ;
- +25 QUIT RETURN
- +26 ;
- CHKSPC(RETURN,DFN,SD) ; Check if status permit cancelation, MBAA RPC: MBAA CANCEL APPOINTMENT
- +1 ;INPUT: RETURN -Looks like flag of 1 or 0 is RETURNed here and by the function
- +2 ; DFN - Patient IEN
- +3 ; SD - Date/Time of appointment
- +4 NEW APT0,STATUS,IND,STAT,STATS
- +5 SET RETURN=0
- +6 ;
- +7 ; get appointment 0 node
- +8 SET APT0=$$GETAPT0^MBAAMDA2(DFN,SD)
- +9 ;
- +10 ;T13 Change to use SDAMA301 API
- +11 ;ICR 4433
- KILL R1
- DO STATUS^MBAARPC1(.R1,DFN,SD,+$GET(APT0))
- SET STATUS=+R1
- KILL R1
- +12 ;S STATUS=+$$STATUS^SDAM1(DFN,SD,+$G(APT0),$G(APT0)) ;ICR#: 2851 MBAA ACCESS TO SDAM1 API get appointment status
- +13 DO LSTCSTA1^MBAAMDA2(.STAT)
- +14 DO BLDLST^MBAAMAPI(.STATS,.STAT)
- +15 SET IND=0
- +16 FOR
- SET IND=$ORDER(STATS(IND))
- if IND=""!(RETURN=1)
- QUIT
- Begin DoDot:1
- +17 IF STATS(IND,"ID")=STATUS
- SET RETURN=1
- QUIT
- End DoDot:1
- +18 ;
- +19 SET RETURN=$GET(RETURN)
- +20 QUIT RETURN
- +21 ;
- +22 ;Line Tags CLNDATA, RECALL, DELETE, CHK, NEWEWL, WFCK, ENRCHK, REQBY is commented out due to the functionality being descoped from the first release
- +23 ;CLNDATA(RETURN,CLINICID) ; returns additional clinic data MBAA ADDITIONAL CLINIC DETAILS
- +24 ; Input: CLINICID - IEN for the Clinic in the Hospital Location file (#44)
- +25 ; Returns:
- +26 ; If Successful:
- +27 ; RETURN(0)="TREATING SPECIALTY^STOP CODE^CREDIT STOP CODE^SPECIALTY"
- +28 ; If Failure:
- +29 ; RETURN(0)="0^Missing CLINICID"
- +30 ; RETURN(0)="0^Clinic doesn't exist."
- +31 ;
- +32 ;I $G(CLINICID)="" S RETURN(0)="0^Missing CLINICID" Q
- +33 ;I '$D(^SC(CLINICID,0)) S RETURN(0)="0^Clinic doesn't exist." Q ;ICR#: 6044
- +34 ;I $P(^SC(CLINICID,0),"^",3)'="C" S RETURN(0)="0^Clinic doesn't exist." Q ;ICR#: 6044
- +35 ;N NODE,STOPPTR,SPECPTR,CREDITPRT,SPECLTY,SPECL,SPEC,SPEC2,STOPCODE,CREDIT,CREDITPTR,CLINIC1,SPEC1 ;IRC#: 6044
- +36 ;S NODE=$G(^SC(CLINICID,0)),STOPPTR=$P(NODE,"^",7),SPECPTR=$P(NODE,"^",20),CREDITPTR=$P(NODE,"^",18)
- +37 ;S STOPCODE=$P(^DIC(40.7,STOPPTR,0),"^"),CREDIT=$P(^DIC(40.7,CREDITPTR,0),"^"),SPEC=$P(^DIC(45.7,SPECPTR,0),"^") ;ICR#: 1024, 362
- +38 ;S SPECLTY=$P(^DIC(45.7,SPECPTR,0),"^",2),SPECL=$P(^DIC(42.4,SPECLTY,0),"^",1) ;ICR#: 430, 362
- +39 ;D GETS^DIQ(44,CLINICID,"8;9.5;2503","IE","CLINIC1")
- +40 ;S SPEC=$G(CLINIC1(44,CLINICID_",",9.5,"I")),STOPCODE=$G(CLINIC1(44,CLINICID_",",8,"E")),CREDIT=$G(CLINIC1(44,CLINICID_",",2503,"E")),SPEC2=$G(CLINIC1(44,CLINICID_",",9.5,"E"))
- +41 ;D GETS^DIQ(45.7,SPEC,".01;1","IE","SPEC1")
- +42 ;S SPECL=$G(SPEC1(45.7,SPEC_",",1,"E"))
- +43 ;S RETURN(0)=$G(SPEC2)_"^"_$G(STOPCODE)_"^"_$G(CREDIT)_"^"_$G(SPECL)
- +44 ;K NODE,STOPPTR,SPECPTR,CREDITPRT,SPECLTY,SPECL,SPEC,STOPCODE,CREDIT,CREDITPTR,CLINIC1,SPEC1
- +45 ;Q
- +46 ;RECALL(RESULTS,DFN,CLINIC,RECALLDT,PTRECDT,PROVIDER,LEN,FAST,TEST,USER,COMMENT) ; adds new patients to the Recall List MBAA RPC: MBAA ADD TO RECALL LIST
- +47 ; Input parameter is the Patient DFN
- +48 ;S RESULTS(0)=1
- +49 ;I $G(DFN)="" S RESULTS(0)="0^DFN is not defined" Q
- +50 ;T13 Change to FM read
- +51 ;N JX S JX=$$GET1^DIQ(2,$G(DFN),.01) I $G(JX)="" S RESULTS(0)="0^Not a patient in this system." Q ;ICR#: 6053 DPT
- +52 ;I '$D(^DPT(DFN,0)) S RESULTS(0)="0^Not a patient in this system." Q ;ICR#: 6053 DPT
- +53 ;I $G(CLINIC)="" S RESULTS(0)="0^Clinic not provided." Q
- +54 ;T13 Change to FM read
- +55 ;I '$D(^SC(CLINIC,0)) S RESULTS(0)="0^Clinic not in the Hospital Location File." Q ;ICR#: 6044
- +56 ;N JX S JX=$$GET1^DIQ(44,$G(CLINIC),.01) I $G(JX)="" S RESULTS(0)="0^Clinic not in the Hospital Location File." Q ;ICR#: 6044
- +57 ;I ($G(RECALLDT)=""!($G(RECALLDT)'>DT)) S RESULTS(0)="0^Provider Recall date not provided or not a valid date. Date must be in the future." Q
- +58 ;I ($G(PTRECDT)=""!($G(PTRECDT)'>DT)) S RESULTS(0)="0^Patient recall date not provided or not a valid date. Date must be in the future" Q
- +59 ;I $G(PROVIDER)="" S RESULTS(0)="0^Provider IEN not provided." Q
- +60 ;I '$D(^VA(200,$G(PROVIDER),0)) S RESULTS(0)="0^Provider not provided." Q
- +61 ;N JX S JX=$$GET1^DIQ(200,$G(PROVIDER),.01) I $G(JX)="" S RESULTS(0)="0^Provider not in the New Person file." Q ;ICR#: 713 VA(200
- +62 ;I $G(LEN)'>0 S RESULTS(0)="0^Appointment length not provided." Q
- +63 ;I $G(FAST)="" S RESULTS(0)="0^FAST code not provided." Q
- +64 ;S FAST=$$LOW^XLFSTR($G(FAST))
- +65 ;I "nf"'[FAST S RESULTS(0)="0^FAST code not provided." Q
- +66 ;I $G(TEST)'>0 S RESULTS(0)="0^Appointment Type code not provided. Appointment Type is a numeric value." Q
- +67 ;I $G(USER)'>0 S RESULTS(0)="0^User IEN not provided." Q
- +68 ;I '$D(^VA(200,$G(USER),0)) S RESULTS(0)="0^User IEN not provided." Q
- +69 ;N JX S JX=$$GET1^DIQ(200,$G(USER),.01) I $G(JX)="" S RESULTS(0)="0^User not in the New Person File." Q ;ICR#: 713 VA(200
- +70 ;S ERR=0 D CHK I ERR=1 S RESULTS(0)="0^Duplicate Recall List Entry" Q
- +71 ;K DO S (DIC,DIE)="^SD(403.5,",DIC(0)="Z",X=DFN,DLAYGO=403.5 D FILE^DICN K DO S NUM=+Y ;ICR#: 6045 SD(403.5
- +72 ;S DA=NUM,DR="4.5///"_$G(CLINIC)_";4///"_$G(PROVIDER)_";2.6///"_$G(FAST)_";4.7///"_$G(LEN)_";5///"_$G(RECALLDT)_";5.5///"_$G(PTRECDT)_";2.5///"_$G(COMMENT)_";3///"_$G(TEST)_";7///"_$G(USER)
- +73 ;D ^DIE
- +74 ;S DA=NUM,DR="[SDRR RECALL CARD ADD]",DIE("NO^")="Not Allowed" D ^DIE
- +75 ;I $D(DTOUT) D DELETE
- +76 ;K DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,DIR,DTOUT
- +77 ;Q
- +78 ;DELETE ;delete new incomplete record and display message MBAA RPC: MBAA ADD TO RECALL LIST
- +79 ;S DIK=DIE
- +80 ;D ^DIK K DIK
- +81 ;S RESULTS(0)="0^All required data was not provided. Recall was not created!"
- +82 ;Q
- +83 ;CHK ; checks to see if the patient is on the recall list for the clinic and provider date MBAA RPC: MBAA ADD TO RECALL LIST
- +84 ;S XX=0 F S XX=$O(^SD(403.5,"B",DFN,XX)) Q:XX'>0 D ;ICR#: 6045 SD(403.5
- +85 ;.;T13 Change to use FM
- +86 ;.N ARRAY,ERR,C1,RD1,P1 D GETS^DIQ(403.5,XX_",","2;4,5","I","ARRAY","ERR") ;ICR#: 6045 SD(403.5
- +87 ;.S C1=$G(ARRAY(403.5,XX_",",2,"I")),RD1=$G(ARRAY(403.5,XX_",",5,"I")),P1=$G(ARRAY(403.5,XX_",",4,"I"))
- +88 ;.I $G(C1)=CLINIC&($G(RD1)=RECALLDT)&($G(P1)=PROVIDER) S ERR=1
- +89 ;.;S NODE=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
- +90 ;.;I ($P(NODE,"^",2)=CLINIC&($P(NODE,"^",6)=RECALLDT)&($P(NODE,"^",5)=PROVIDER)) S ERR=1
- +91 ;I $G(ERR)>0 S ERR=1
- +92 ;Q
- +93 ;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
- +94 ;CLNRGHT(RV,CLN) ;
- +95 ; N STATUS,RESULT S STATUS=$$CLNRGHT^MBAAMAP1(.RESULT,CLN)
- +96 ; ;D MERGE^MBAAMRPC(.RV,.RESULT)
- +97 ; S RV(0)=$G(RESULT)
- +98 ; Q
- NEWEWL(RV,SDWLD) ; ZLV EWL NEW
- +1 ;alb/sat 4 - existing Y needs to be Newed
- NEW Y
- +2 IF $GET(SDWLD)=""
- SET RV(0)="0^SDWLD List missing."
- QUIT
- +3 SET SDWLD("WLTYPE")=$PIECE($GET(SDWLD),"^",1)
- +4 IF SDWLD("WLTYPE")=""
- SET RV(0)="0^INVPARAM WLTYPE IS NULL"
- QUIT
- +5 IF $GET(SDWLD("WLTYPE"))'>0!($GET(SDWLD("WLTYPE"))'<5)
- SET RV(0)="0^INVPARAM WLTYPE"
- QUIT
- +6 SET SDWLD("PATIENT")=$PIECE($GET(SDWLD),"^",2)
- +7 IF SDWLD("PATIENT")=""
- SET RV(0)="0^INVPARAM PATIENT IS NULL"
- QUIT
- +8 ;ICR#: 6053 DPT
- SET DFN=$GET(SDWLD("PATIENT"))
- IF '$DATA(^DPT(DFN,0))
- SET RV(0)="0^INVPARAM PATIENT DOESN'T EXIST."
- KILL DFN
- QUIT
- +9 SET SDWLD("INSTITUTION")=$PIECE($GET(SDWLD),"^",3)
- +10 IF SDWLD("INSTITUTION")=""
- SET RV(0)="0^INVPARAM INSTITUTION IS NULL"
- QUIT
- +11 ;ICR#:3795 XUMF
- NEW SITE
- SET X=$GET(SDWLD("INSTITUTION"))
- SET SITE=$$IEN^XUMF(4,,X)
- IF +$GET(SITE)'>0
- SET RV(0)="0^INVPARAM INVALID INSTITUTION NUMBER."
- QUIT
- +12 SET SDWLD("WAITFOR")=$PIECE($GET(SDWLD),"^",4)
- +13 IF SDWLD("WAITFOR")=""
- SET RV(0)="0^INVPARAM WAITFOR IS NULL"
- QUIT
- +14 ;S ERR=0 D WFCK Q:$G(ERR)>0
- +15 SET SDWLD("PRIORITY")=$PIECE($GET(SDWLD),"^",5)
- +16 IF SDWLD("PRIORITY")=""
- SET RV(0)="0^INVPARAM PRIORITY IS NULL"
- QUIT
- +17 IF SDWLD("PRIORITY")'="A"
- IF (SDWLD("PRIORITY")'="F")
- SET RV(0)="0^INVPARAM INVALID PRIORITY"
- QUIT
- +18 SET SDWLD("REQBY")=$PIECE($GET(SDWLD),"^",6)
- +19 DO REQBY
- +20 if $GET(ERR)=1
- QUIT
- +21 SET SDWLD("PROVIDER")=$PIECE($GET(SDWLD),"^",7)
- +22 IF SDWLD("PROVIDER")'=""
- Begin DoDot:1
- +23 NEW IEN
- SET ERR=0
- SET IEN=$GET(SDWLD("PROVIDER"))
- +24 ;ICR#: 713 VA(200
- NEW JX
- SET JX=$$GET1^DIQ(200,$GET(IEN),.01)
- IF $GET(JX)=""
- SET ERR=1
- SET RV(0)="0^INVPARAM PROVIDER IS NOT IN THE NEW PERSON FILE"
- QUIT
- +25 ;I '$D(^VA(200,IEN,0)) S ERR=1,RV(0)="0^INVPARAM PROVIDER IS NOT IN THE NEW PERSON FILE" Q ;ICR#: 713 VA(200
- +26 ;ICR#: 10076 XUSEC
- IF '$DATA(^XUSEC("PROVIDER",IEN))
- SET ERR=1
- SET RV(0)="0^INVPARAM NOT A PROVIDER"
- QUIT
- End DoDot:1
- +27 if $GET(ERR)=1
- QUIT
- +28 SET SDWLD("SCPRCNT")=$PIECE($GET(SDWLD),"^",8)
- +29 IF SDWLD("SCPRCNT")'=""
- Begin DoDot:1
- +30 SET ERR=0
- IF SDWLD("SCPRCNT")'>0!(SDWLD("SCPRCNT")'<101)
- SET ERR=1
- SET RV(0)="0^INVPARAM SERVICE CONNECTED PERCENTAGE"
- QUIT
- End DoDot:1
- +31 if $GET(ERR)=1
- QUIT
- +32 SET SDWLD("SCPRIORITY")=$PIECE($GET(SDWLD),"^",9)
- +33 IF SDWLD("SCPRIORITY")'=""
- Begin DoDot:1
- +34 SET ERR=0
- IF $GET(SDWLD("SCPRIORITY"))'=0
- IF ($GET(SDWLD("SCPRIORITY"))'=1)
- SET ERR=1
- SET RV(0)="0^INVPARAM INVALID PRIORITY"
- QUIT
- End DoDot:1
- +35 if $GET(ERR)=1
- QUIT
- +36 SET SDWLD("DSRDDT")=$PIECE($GET(SDWLD),"^",10)
- +37 IF SDWLD("DSRDDT")=""
- SET RV(0)="0^INVPARAM DESIRED DATE OF APPOINTMENT IS NULL"
- QUIT
- +38 SET ERR=0
- SET X=$GET(SDWLD("DSRDDT"))
- DO ^%DT
- IF Y=-1
- SET ERR=0
- SET RV(0)="0^INVPARAM NOT A VALID DATE"
- QUIT
- +39 if $GET(ERR)=1
- QUIT
- +40 SET SDWLD("CMNTS")=$PIECE($GET(SDWLD),"^",11)
- +41 IF SDWLD("CMNTS")'=""
- Begin DoDot:1
- +42 IF $LENGTH($GET(SDWLD("CMNTS")))'>0!($LENGTH($GET(SDWLD("CMNTS")))'<61)
- SET ERR=1
- SET RV(0)="0^INVPARAM COMMENTS ARE TOO LONG"
- QUIT
- End DoDot:1
- +43 if $GET(ERR)=1
- QUIT
- +44 SET SDWLD("ENRSTAT")=$PIECE($GET(SDWLD),"^",12)
- +45 IF SDWLD("ENRSTAT")=""
- SET RV(0)="0^INVPARAM ENROLLEE STATUS IS NULL"
- QUIT
- +46 SET ERR=0
- DO ENRCHK
- if $GET(ERR)=1
- QUIT
- +47 SET SDWLD("ENRDU")=$PIECE($GET(SDWLD),"^",13)
- +48 IF SDWLD("ENRDU")'=""
- Begin DoDot:1
- +49 SET ERR=0
- SET X=$GET(SDWLD("ENRDU"))
- DO ^%DT
- IF $GET(Y)=-1
- SET ERR=1
- SET RV(0)="0^INVPARAM ENROLLEE DATE INVALID DATE"
- QUIT
- End DoDot:1
- +50 if $GET(ERR)=1
- QUIT
- +51 SET SDWLD("ENRDF")=$PIECE($GET(SDWLD),"^",14)
- +52 IF SDWLD("ENRDF")'=""
- Begin DoDot:1
- +53 SET ERR=0
- IF $GET(SDWLD("ENRDF"))'=0
- IF ($GET(SDWLD("ENRDF"))'<5)
- SET ERR=1
- SET RV(0)="0^INVPARAM ENROLLEE DATABASE FILE"
- QUIT
- End DoDot:1
- +54 if ERR=1
- QUIT
- +55 SET SDWLD("TICKLER")=$PIECE($GET(SDWLD),"^",15)
- +56 IF SDWLD("TICKLER")'=""
- Begin DoDot:1
- +57 SET SDWLD("TICKLER")=$$UP^XLFSTR($GET(SDWLD("TICKLER")))
- +58 SET ERR=0
- IF $GET(SDWLD("TICKLER"))'="Y"
- SET ERR=1
- SET RV(0)="0^INVPARAM TICKLER"
- QUIT
- End DoDot:1
- +59 if ERR=1
- QUIT
- +60 SET SDWLD("CHDCLINP")=$PIECE($GET(SDWLD),"^",16)
- +61 IF SDWLD("CHDCLINP")'=""
- Begin DoDot:1
- +62 NEW APTR
- +63 ;ICR#: 6046 SDWL(409.3
- SET ERR=0
- SET PTR=$GET(SDWLD("CHDCLINP"))
- IF '$DATA(^SDWL(409.3,PTR,0))
- SET ERR=1
- SET RV(0)="0^INVPARAM CHANGED CLINIC PARENT POINTER IS NOT VALID"
- QUIT
- +64 ;T13 Change to use FM
- +65 ;ICR#: 6046 SDWL(409.3
- IF $DATA(^SDWL(409.3,PTR,0))
- SET APTR=$$GET1^DIQ(409.3,PTR_",",".01","I")
- IF APTR'=SDWLD("PATIENT")
- SET ERR=1
- SET RV(0)="0^INVPARAM CHANGED CLINIC PARENT POINTER IS FOR A DIFFERENT PATIENT"
- QUIT
- +66 ;I $D(^SDWL(409.3,PTR,0)) S APTR=$P(^SDWL(409.3,PTR,0),"^",1) I APTR'=SDWLD("PATIENT") S ERR=1,RV(0)="0^INVPARAM CHANGED CLINIC PARENT POINTER IS FOR A DIFFERENT PATIENT" Q ;ICR#: 6046 SDWL(409.3
- +67 KILL APTR
- End DoDot:1
- +68 if ERR=1
- QUIT
- +69 IF SDWLD("WLTYPE")=3!(SDWLD("WLTYPE")=4)
- Begin DoDot:1
- +70 KILL ERR
- SET ERR=0
- +71 IF SDWLD("REQBY")'=1
- IF $GET(SDWLD("REQBY"))'=2
- SET ERR=1
- End DoDot:1
- +72 IF ERR=1
- KILL ERR
- SET RV(0)="0^INVPARAM REQBY"
- QUIT
- +73 NEW STATUS,RESULT
- SET STATUS=$$NEW^MBAAWLAP(.RESULT,.SDWLD)
- +74 IF 'STATUS
- SET RV=-1
- +75 IF $GET(STATUS)
- SET RV(0)=1
- +76 KILL ERR,X,IEN,DFN,PTR,CHK,TYPE,REQBY
- +77 QUIT
- +78 ;WFCK ; Check to make sure the pointer is valid for the Waitfor parameter
- +79 ;N PTR S PTR=$G(SDWLD("WAITFOR")),ERR=0
- +80 ;I SDWLD("WLTYPE")=1 D
- +81 ;.;I '$D(^SCTM(404.51,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID TEAM" Q ;ICR#: 1945 DBIA 1945
- +82 ;.N JX S JX=$$GET1^DIQ(404.51,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID TEAM" Q ;ICR#: 1945 DBIA 1945
- +83 ;Q:$G(ERR)>0
- +84 ;I SDWLD("WLTYPE")=2 D
- +85 ;.;I '$D(^SCTM(404.57,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID POSITION" Q ;ICR#: 6064 MBAA ACCESS TO SCTM(404.57
- +86 ;.N JX S JX=$$GET1^DIQ(404.57,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID POSITION" Q ;ICR#: 6064 MBAA ACCESS TO SCTM(404.57
- +87 ;Q:$G(ERR)>0
- +88 ;I SDWLD("WLTYPE")=3 D
- +89 ;.;I '$D(^SDWL(409.31,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID SPECIALTY" Q ;ICR#: 6046 SDWL(409.3
- +90 ;.N JX S JX=$$GET1^DIQ(409.31,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID SPECIALTY" Q ;ICR#: 6046 SDWL(409.3
- +91 ;Q:$G(ERR)>0
- +92 ;I SDWLD("WLTYPE")=4 D
- +93 ;.;I '$D(^SDWL(409.32,PTR,0)) S ERR=1,RV(0)="0^INVPARAM INVALID WAIT LIST CLINIC" Q ;ICR#: 6046 SDWL(409.3
- +94 ;.N JX S JX=$$GET1^DIQ(409.32,$G(PTR),.01) I $G(JX)="" S ERR=1,RV(0)="0^INVPARAM INVALID WAIT LIST CLINIC" Q ;ICR#: 6046 SDWL(409.3
- +95 ;Q:$G(ERR)>0
- +96 ;I SDWLD("WLTYPE")>5 S RV(0)="0^INVPARAM WAIT LIST TYPE" Q
- +97 ;Q
- ENRCHK ; Check enrollee status codes - must be either N, E, P or U
- +1 SET CHK=$GET(SDWLD("ENRSTAT"))
- +2 IF CHK'="N"
- IF (CHK'="E")
- IF (CHK'="P")
- IF (CHK'="U")
- SET ERR=1
- SET RV(0)="0^INVPARAM INVALID ENROLLEE STATUS"
- QUIT
- +3 QUIT
- REQBY ; Checksto be sure a correct value for the REQBY parameter is correct based on the Wait List Type
- +1 SET ERR=0
- SET TYPE=$GET(SDWLD("WLTYPE"))
- SET REQBY=$GET(SDWLD("REQBY"))
- +2 IF $GET(REQBY)'=1
- IF ($GET(REQBY)'=2)
- IF ($GET(REQBY)'="")
- SET ERR=1
- SET RV(0)="0^INVPARAM INVALID REQBY"
- QUIT
- +3 IF $GET(REQBY)'=""
- Begin DoDot:1
- +4 IF TYPE=3
- IF (TYPE=4)
- Begin DoDot:2
- +5 IF REQBY'=1
- IF (REQBY'=2)
- SET ERR=1
- SET RV(0)="0^INVPARAM INVALID REQBY"
- QUIT
- End DoDot:2
- +6 IF TYPE=1
- IF (TYPE=2)
- Begin DoDot:2
- +7 IF REQBY=1
- IF (REQBY'=2)
- SET ERR=1
- SET RV(0)="0^INVPARAM INVALID REQBY"
- QUIT
- End DoDot:2
- End DoDot:1
- +8 IF $GET(REQBY)=""
- Begin DoDot:1
- +9 IF TYPE'=1
- IF (TYPE'=2)
- SET ERR=1
- SET RV(0)="0^INVPARAM INVALID REQBY"
- QUIT
- End DoDot:1
- +10 QUIT
