MBAARPCL ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
;;1.0;Scheduling Calendar View;**1**;Feb 10, 2016;Build 85
;
;Associated ICRs:
; ICR#
; 6045 SD(403.5
; 10061 VADPT
; 6044 SC(
; 10112 VASITE
; 6053 DPT
; 10103 XLFDT
; 6047 SDWL(409.32
; 1024 DIC(40.7
; 6046 SDWL(409.3
;
;This routine has multiple RPCs created to support the mobile Scheduling apps
RECALL(RESULTS) ;pull a list of recalls for a facility MBAA RPC: MBAA RECALL FACILITY LIST
; No input parameters
; Output: RESULTS Array:
; $P(1) = DFN
; $P(2) = PTR TO CLINIC FILE
; $P(3) = ACCESSION#
; $P(4) = TEST/APP - PTR TO FILE 403.51
; $P(5) = PROVIDER - PTR TO FILE 405.54
; $P(6) = RECALL DATE PER PROVIDER
; $P(7) = COMMENT
; $P(8) = FAST/NON-FASTING (SET OF CODES: f = Fasting, n = Non- Fasting)
; $P(9) = LENGTH OF APPOINTMENT
; $P(10) = DATE REMINDER SENT
; $P(11) = USER WHO ENTERED RECALL (PTR to file 200)
; $P(12) = RECALL DATE (PER PATIENT)
; $P(13) = SECOND PRINT DATE
; $P(14) = PATIENT NAME (LAST,FIRST)
; $P(15) = PATIENT SSN
; $P(16) = CLINIC NAME
;
S CNT=0 S XX=0 F S XX=$O(^SD(403.5,XX)) Q:XX'>0 D ;ICR#: 6045 SD(403.5
.K DFN,LNAME,SSN,CLINIC,CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT
.;T13 Change to FM read
.;S NODE=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
.;S DFN=$P(NODE,"^"),CIEN=$P(NODE,"^",2)
.;D DEM^VADPT ;ICR#: 10061 VADPT
.;S LNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
.;I $G(CIEN)>0 S CLINIC=$P(^SC(CIEN,0),"^") ;ICR#: 6044 SC(
.;S ACCESS=$P(NODE,"^",3),TESTAPP=$P(NODE,"^",4),PROVIDER=$P(NODE,"^",5),RECALLDT=$P(NODE,"^",6)
.;S COMMENT=$P(NODE,"^",7),FASTNON=$P(NODE,"^",8),APPTLEN=$P(NODE,"^",9),REMINDDT=$P(NODE,"^",10)
.;S USER=$P(NODE,"^",11),PATRECDT=$P(NODE,"^",12),SECPRT=$P(NODE,"^",13)
.;S RESULTS(CNT)=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
.N ARRAY D GETS^DIQ(403.5,$G(XX),"**","IE","ARRAY")
.S DFN=$G(ARRAY(403.5,XX_",",.01,"I")),LNAME=$G(ARRAY(403.5,XX_",",.01,"E")),CIEN=$G(ARRAY(403.5,XX_",",4.5,"I")),CLINIC=$G(ARRAY(403.5,XX_",",4.5,"E"))
.D DEM^VADPT S SSN=$P($G(VADM(2)),"^",2)
.S ACCESS=$G(ARRAY(403.5,XX_",",2,"I")),TESTAPP=$G(ARRAY(403.5,XX_",",3,"I")),PROVIDER=$G(ARRAY(403.5,XX_",",4,"I")),RECALLDT=$G(ARRAY(403.5,XX_",",5,"I"))
.S COMMENT=$G(ARRAY(403.5,XX_",",2.5,"I")),FASTNON=$G(ARRAY(403.5,XX_",",2.6,"I")),APPTLEN=$G(ARRAY(403.5,XX_",",4.7,"I"))
.S REMINDDT=$G(ARRAY(403.5,XX_",",6,"I")),USER=$G(ARRAY(403.5,XX_",",7,"I")),PATRECDT=$G(ARRAY(403.5,XX_",",5.5,"I")),SECPRT=$G(ARRAY(403.5,XX_",",8,"I"))
.S RESULTS(CNT)=$G(DFN)_U_$G(CIEN)_U_$G(ACCESS)_U_$G(TESTAPP)_U_$G(PROVIDER)_U_$G(RECALLDT)_U_$G(COMMENT)_U_$G(FASTNON)_U_$G(APPTLEN)_U_$G(REMINDDT)_U_$G(USER)_U_$G(PATRECDT)_U_$G(SECPRT)_U_$G(LNAME)_U_$G(SSN)_U_$G(CLINIC)
.;S:$P(RESULTS(CNT),"^",13)="" RESULTS(CNT)=$G(RESULTS(CNT))_"^^"_$G(LNAME)_"^"_$G(SSN)_"^"_$G(CLINIC)
.S CNT=CNT+1
.D KVA^VADPT
S:$G(RESULTS(0))="" RESULTS(0)="1^RECALL LIST EMPTY"
K XDT,XX,CNT,DFN,LNAME,VA("PID"),VA("BID"),SSN,CLINIC,CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT,SECPRT
Q
RCLDFN(RESULTS,DFN) ;pull a list of recalls by patient MBAA RPC: MBAA RECALL LIST BY PATIENT
; Input parameter = DFN (PTR to Patient file #2)
; Output: RESULTS Array:
; $P(1) = DFN
; $P(2) = PTR TO CLINIC FILE
; $P(3) = ACCESSION#
; $P(4) = TEST/APP - PTR TO FILE 403.51
; $P(5) = PROVIDER - PTR TO FILE 405.54
; $P(6) = RECALL DATE PER PROVIDER
; $P(7) = COMMENT
; $P(8) = FAST/NON-FASTING (SET OF CODES: f = Fasting, n = Non- Fasting)
; $P(9) = LENGTH OF APPOINTMENT
; $P(10) = DATE REMINDER SENT
; $P(11) = USER WHO ENTERED RECALL (PTR to file 200)
; $P(12) = RECALL DATE (PER PATIENT)
; $P(13) = SECOND PRINT DATE
; $P(14) = PATIENT NAME (LAST,FIRST)
; $P(15) = PATIENT SSN
; $P(16) = CLINIC NAME
;
K RESULTS
I $G(DFN)="" S RESULTS(0)="1^DFN HAS TO BE SUPPLIED" Q
S RESULTS(0)="1^RECALL LIST EMPTY"
S CNT=0,XX=0 F S XX=$O(^SD(403.5,"B",DFN,XX)) Q:XX'>0 D ;ICR#: 6045 SD(403.5
.K LNAME,SSN,CLINIC,CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT
.;T13 Change to FM read
.;S NODE=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
.;S CIEN=$P(NODE,"^",2)
.;D DEM^VADPT ;ICR#: 10061 VADPT
.;S LNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
.;I $G(CIEN)>0 S CLINIC=$P(^SC(CIEN,0),"^") ;ICR#: 6044 SC(
.;S ACCESS=$P(NODE,"^",3),TESTAPP=$P(NODE,"^",4),PROVIDER=$P(NODE,"^",5),RECALLDT=$P(NODE,"^",6)
.;S COMMENT=$P(NODE,"^",7),FASTNON=$P(NODE,"^",8),APPTLEN=$P(NODE,"^",9),REMINDDT=$P(NODE,"^",10)
.;S USER=$P(NODE,"^",11),PATRECDT=$P(NODE,"^",12),SECPRT=$P(NODE,"^",13)
.;S RESULTS(CNT)=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
.N ARRAY D GETS^DIQ(403.5,$G(XX),"**","IE","ARRAY")
.S DFN=$G(ARRAY(403.5,XX_",",.01,"I")),LNAME=$G(ARRAY(403.5,XX_",",.01,"E")),CIEN=$G(ARRAY(403.5,XX_",",4.5,"I")),CLINIC=$G(ARRAY(403.5,XX_",",4.5,"E"))
.D DEM^VADPT S SSN=$P($G(VADM(2)),"^",2)
.S ACCESS=$G(ARRAY(403.5,XX_",",2,"I")),TESTAPP=$G(ARRAY(403.5,XX_",",3,"I")),PROVIDER=$G(ARRAY(403.5,XX_",",4,"I")),RECALLDT=$G(ARRAY(403.5,XX_",",5,"I"))
.S COMMENT=$G(ARRAY(403.5,XX_",",2.5,"I")),FASTNON=$G(ARRAY(403.5,XX_",",2.6,"I")),APPTLEN=$G(ARRAY(403.5,XX_",",4.7,"I"))
.S REMINDDT=$G(ARRAY(403.5,XX_",",6,"I")),USER=$G(ARRAY(403.5,XX_",",7,"I")),PATRECDT=$G(ARRAY(403.5,XX_",",5.5,"I")),SECPRT=$G(ARRAY(403.5,XX_",",8,"I"))
.S RESULTS(CNT)=$G(DFN)_U_$G(CIEN)_U_$G(ACCESS)_U_$G(TESTAPP)_U_$G(PROVIDER)_U_$G(RECALLDT)_U_$G(COMMENT)_U_$G(FASTNON)_U_$G(APPTLEN)_U_$G(REMINDDT)_U_$G(USER)_U_$G(PATRECDT)_U_$G(SECPRT)_U_$G(LNAME)_U_$G(SSN)_U_$G(CLINIC)
.;S RESULTS(CNT)=$G(^SD(403.5,XX,0))
.;S:$P(RESULTS(CNT),"^",13)="" RESULTS(CNT)=$G(RESULTS(CNT))_"^"
.S CNT=CNT+1
.D KVA^VADPT
K XDT,XX,CNT
K DFN,LNAME,SSN,CLINIC,VA("PID"),VA("BID"),CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT
Q
NEARLST(RESULTS) ;Gets the NEAR List for a Facility MBAA RPC: MBAA FACILITY NEAR LIST
; No input parameters required
; Output: TMP($J,"NEAR")=DFN^PATIENTNAME^SSN^ELIGIBILITY CODE INTERNAL^ELIGIBILITY CODE EXTERNAL^HOME PHONE^CELL PHONE^DATE^SITE
; DFN = PATIENT ID
; PATIENTNAME = PATIENT NAME
; SSN = LAST FOUR OF SSN
; ELIGIBILITY CODE INTERNAL = INTERNAL ELIGIBILITY CODE
; ELIGIBILITY CODE EXTERNAL = EXTERNAL ELIGIBILITY CODE
; HOME PHONE
; CELL PHONE
; DATE = APPOINTMENT DATE REQUESTED
; SITE = FACILITY ID
;-Build temp global
K ^TMP($J,"NEAR")
N DFNIEN,DGSITE,PNAME,SSN,ELIG,PHONE,CELL,DFN
S DGSITE=+$$SITE^VASITE() ;ICR#: 10112 VASITE
S (CNT,DFNIEN)=0 F S DFNIEN=$O(^DPT("AEAR",1,DFNIEN)) Q:'DFNIEN D ;ICR#: 6053 DPT
.I $$GET1^DIQ(2,DFNIEN,1010.159,"I") D
.Q:$P($G(^DPT(DFNIEN,1010.16)),"^",1)'="" ;ICR#: 6053 DPT
.S DFN=DFNIEN D DEM^VADPT,ELIG^VADPT,ADD^VADPT ;ICR#: 10061 VADPT
.S CNT=CNT+1
.;T13 Change to get cell phone using FM read
.;S PNAME=VADM(1),SSN=+VADM(2),ELIG=VAEL(1),PHONE=VAPA(8),CELL=$P($G(^DPT(DFNIEN,.13)),"^",4) ;ICR#: 6053 DPT
.S PNAME=VADM(1),SSN=+VADM(2),ELIG=VAEL(1),PHONE=VAPA(8),CELL=$$GET1^DIQ(2,100841,.01,"I") ;ICR#: 6053 DPT
.I $G(ELIG)="" S ELIG="^"
.S ^TMP($J,"NEAR",CNT)=DFNIEN_"^"_$G(PNAME)_"^"_$G(SSN)_"^"_$G(ELIG)_"^"_$G(PHONE)_"^"_$G(CELL)_"^"_$$GET1^DIQ(2,DFNIEN,1010.1511,"I")_"^"_DGSITE_$C(10)
.K PNAME,DFN,SSN,ELIG,PHONE,CELL
.D KVA^VADPT
S RESULTS=$NA(^TMP($J,"NEAR"))
K DFN,VADM,VAEL,VAPA,VA("BID"),VA("PID"),VACNTRY,VAERR
Q
;
NEARDFN(RESULTS,DFN) ;Gets the NEAR List for a PATIENT MBAA RPC: MBAA PATIENT NEAR LIST
; INPUT: Patient DFN
; Output:
; If the patient is on the NEAR List, returns the array:
; DFN^PATIENTNAME^SSN^ELIGIBILITY CODE INTERNAL^ELIGIBILITY CODE EXTERNAL^HOME PHONE^CELL PHONE^DATE^SITE
; DFN = PATIENT ID
; PATIENTNAME = PATIENT NAME
; SSN = LAST FOUR OF SSN
; ELIGIBILITY CODE INTERNAL = INTERNAL ELIGIBILITY CODE
; ELIGIBILITY CODE EXTERNAL = EXTERNAL ELIGIBILITY CODE
; HOME PHONE
; CELL PHONE
; DATE = APPOINTMENT DATE REQUESTED
; SITE = FACILITY ID
; If the patient is not on the NEAR List returns "1^Patient not on the NEAR List"
N DGSITE,SSN,ELIG,PHONE,CELL,PNAME
I $G(DFN)="" S RESULTS(0)="1^DFN IS NOT DEFINED" Q
S RESULTS(0)=""
I $$GET1^DIQ(2,DFN,1010.159,"I") D
.Q:$P($G(^DPT(DFN,1010.16)),"^",1)'="" ;ICR#: 6053 DPT
.S DGSITE=+$$SITE^VASITE()
.D DEM^VADPT,ELIG^VADPT,ADD^VADPT ;ICR#: 10061 VADPT
.;T13 Change to get cell phone using FM read
.;S PNAME=VADM(1),SSN=+VADM(2),ELIG=VAEL(1),PHONE=VAPA(8),CELL=$P($G(^DPT(DFN,.13)),"^",4) ;ICR#: 6053 DPT
.S PNAME=VADM(1),SSN=+VADM(2),ELIG=VAEL(1),PHONE=VAPA(8),CELL=$$GET1^DIQ(2,100841,.01,"I") ;ICR#: 6053 DPT
.I $G(ELIG)="" S ELIG="^"
.S RESULTS(0)=DFN_"^"_$G(PNAME)_"^"_$G(SSN)_"^"_$G(ELIG)_"^"_$G(PHONE)_"^"_$G(CELL)_"^"_$$GET1^DIQ(2,DFN,1010.1511,"I")_"^"_DGSITE
.D KVA^VADPT
I RESULTS(0)="" S RESULTS(0)="1^Patient not on the NEAR List"
K DFN,VADM,VAEL,VAPA,VA("BID"),VA("PID"),VACNTRY,VAERR
Q
EWL(RESULTS,DFN) ; gets the EWL data by patient as described in the output data MBAA RPC: MBAA WAIT LIST BY DFN
; Input: Patient DFN (PTR to Patient File (#2))
; Outputs if successful - patient is on the EWL:
; $P(1) = DFN
; $P(2) = DSS STOP CODE
; $P(3) = LAST UPDATED (RETURNED IN FILEMAN FORMAT)
; $P(4) = PATIENT NAME
; $P(5) = PATIENT SSN
; $P(6) = CLINIC NAME
; $P(7) = ORIGINATING DATE (RETURNED IN FILEMAN FORMAT)
; $P(8) = DESIRED DATE OF APPOINTMENT
; $P(9) = DAYS ON EWL
; $P(10) = DATE REMOVED FROM EWL (RETURNED IN FILEMAN FORMAT)
; $P(11) = PATIENT ZIP CODE
; $P(12) = SERVICE CONNECTED %
; $P(13) = ENROLLEE STATUS
; $P(14) = PRIORITY
; $P(15) = CLINIC ID
; $P(16) = IEN FROM SDWL(409.3 FOR THE ENTRY
;
; If patient is not on the EWL, returns
; RESULTS(0)="1^PATIENT NOT ON THE EWL."
;
I $G(DFN)="" S RESULTS(0)="1^DFN IS NOT DEFINED" Q
I '$D(^SDWL(409.3,"B",DFN)) S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q ;ICR#: 6046 SDWL(409.3
S REC=0,CNT=1 F S REC=$O(^SDWL(409.3,"B",DFN,REC)) Q:REC'>0 D ;ICR#: 6046 SDWL(409.3
.;T13 Change to use FM reads
.;S NODE=$G(^SDWL(409.3,REC,0)) ;ICR#: 6046 SDWL(409.3
.;Q:$G(NODE)=""
.;I $P($G(NODE),"^",17)="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
.;I $P($G(NODE),"^",17)="O" S RESULTS(0)=""
.I $$GET1^DIQ(409.3,REC,23,"I")="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
.I $$GET1^DIQ(409.3,REC,23,"I")="O" S RESULTS(0)=""
.N SDWL1
.D GETS^DIQ(409.3,REC_",","1;8;10;13.1;14;22;23;27","IE","SDWL1")
.D NOW^%DTC,DEM^VADPT,ADD^VADPT ;ICR#: 10061 VADPT
.S (ORIGDT,LASTUPDT)=$G(SDWL1(409.3,REC_",",1,"I")),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
.;S (ORIGDT,LASTUPDT)=$P(NODE,"^",2),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
.S PTNAME=$G(VADM(1)) ;,LASTNAME=$P(PTNAME,",")
.S SSN=$P($G(VADM(2)),"^",2),ZIP=$G(VAPA(6))
.S DESIRED=$G(SDWL1(409.3,REC_",",22,"I")),CLINIEN=$G(SDWL1(409.3,REC_",",8,"I"))
.;S DESIRED=$P(NODE,"^",16),CLINIEN=$P(NODE,"^",9)
.I $G(CLINIEN)'="" D
..S PTR=$$GET1^DIQ(409.32,CLINIEN_",",".01","I") ;ICR#: 6047 SDWL(409.32
..K CLIN1 D GETS^DIQ(44,PTR_",",".01;8","IE","CLIN1") S CLINNAME=$G(CLIN1(44,PTR_",",.01,"E")),STPCODE=$G(CLIN1(44,PTR_",",8,"E"))
.;S SC=$P($G(^SDWL(409.3,REC,"SC")),"^",1),PRIOR=$P(NODE,"^",11),ENRSTAT1=$P(NODE,"^",20) ;ICR#: 6046 SDWL(409.3
.S SC=$G(SDWL1(409.3,REC_",",14,"E")),PRIOR1=$G(SDWL1(409.3,REC_",",10,"E")),ENRSTAT=$G(SDWL1(409.3,REC_",",27,"E")) ;ICR#: 6046 SDWL(409.3
.;S DTREMOVE=$P($G(^SDWL(409.3,REC,"SDAPT")),"^",1) ;ICR#: 6046 SDWL(409.3
.S DTREMOVE=$G(SDWL1(409.3,REC_",",13.1,"I")) ;ICR#: 6046 SDWL(409.3
.;I ENRSTAT1'="" S ENRSTAT=$S(ENRSTAT1="N":"NEW",ENRSTAT1="E":"ESTABLISHED",ENRSTAT1="P":"PRIOR",ENRSTAT1="U":"UNDETERMINED",1:"UNKNOWN")
.;I PRIOR'="" S PRIOR1=$S(PRIOR="A":"ASAP",PRIOR="F":"FUTURE",1:0)
.S RESULTS(CNT)=DFN_U_$G(STPCODE)_U_$G(LASTUPDT)_U_$G(PTNAME)_U_$G(SSN)_U_$G(CLINNAME)_U_$G(ORIGDT)_U_$G(DESIRED)_U_$G(DAYSON)_U_$G(DTREMOVE)_U_$G(ZIP)_U_$G(SC)_U_$G(ENRSTAT)_U_$G(PRIOR1)_U_$G(CLINIEN)_U_$G(REC),CNT=CNT+1
.D KVA^VADPT
.K NODE,%,ORIGDT,LASTUPDT,DAYSON,PTNAME,LASTNAME,SSN
.K DESIRED,CLINIEN,PTR,CLINNAME,STOPPTR,STPCODE,PRIOR,ENRSTAT,SC,ENRSTAT1,PRIOR1,DTREMOVE,ZIP,CLIN1,SDWL1
K REC,CNT,REC,DFN
Q
FACEWL(RESULTS) ; gets the EWL data for a facility as described in the output data MBAA RPC: MBAA FACILITY WAIT LIST
; Outputs if successful - patient is on the EWL:
; $P(1) = DFN
; $P(2) = DSS STOP CODE
; $P(3) = LAST UPDATED (RETURNED IN FILEMAN FORMAT)
; $P(4) = PATIENT NAME
; $P(5) = PATIENT SSN
; $P(6) = CLINIC NAME
; $P(7) = ORIGINATING DATE (RETURNED IN FILEMAN FORMAT)
; $P(8) = DESIRED DATE OF APPOINTMENT
; $P(9) = DAYS ON EWL
; $P(10) = DATE REMOVED FROM EWL (RETURNED IN FILEMAN FORMAT)
; $P(11) = PATIENT ZIP CODE
; $P(12) = SERVICE CONNECTED %
; $P(13) = ENROLLEE STATUS
; $P(14) = PRIORITY
; $P(15) = CLINIC ID
; $P(16) = IEN FROM SDWL(409.3 FOR THE ENTRY
;
; If no patients are not on the EWL, returns
; RESULTS(0)="1^EWL is empty."
;
I '$D(^SDWL(409.3,"B")) S RESULTS(0)="1^EWL is empty." Q ;ICR#: 6046 SDWL(409.3
S REC=0,CNT=0,DFN=0 F S DFN=$O(^SDWL(409.3,"B",DFN)) Q:DFN'>0 F S REC=$O(^SDWL(409.3,"B",DFN,REC)) Q:REC'>0 D ;ICR#: 6046 SDWL(409.3
.;T13 Change to use FM reads
.;S NODE=$G(^SDWL(409.3,REC,0)) ;ICR#: 6046 SDWL(409.3
.;Q:$G(NODE)=""
.;I $P($G(NODE),"^",17)="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
.;I $P($G(NODE),"^",17)="O" S RESULTS(0)=""
.;I $$GET1^DIQ(409.3,REC,23,"I")="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
.;I $$GET1^DIQ(409.3,REC,23,"I")="O" S RESULTS(0)=""
.Q:$$GET1^DIQ(409.3,REC,23,"I")="C"
.N SDWL1
.K SEWL1 D GETS^DIQ(409.3,REC_",","1;8;10;13.1;14;22;23;27","IE","SDWL1")
.D NOW^%DTC,DEM^VADPT,ADD^VADPT ;ICR#: 10061 VADPT
.S (ORIGDT,LASTUPDT)=$G(SDWL1(409.3,REC_",",1,"I")),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
.;S (ORIGDT,LASTUPDT)=$P(NODE,"^",2),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
.S PTNAME=$G(VADM(1)) ;,LASTNAME=$P(PTNAME,",")
.S SSN=$P($G(VADM(2)),"^",2),ZIP=$G(VAPA(6))
.S DESIRED=$G(SDWL1(409.3,REC_",",22,"I")),CLINIEN=$G(SDWL1(409.3,REC_",",8,"I"))
.;S DESIRED=$P(NODE,"^",16),CLINIEN=$P(NODE,"^",9)
.I $G(CLINIEN)'="" D
..S PTR=$$GET1^DIQ(409.32,CLINIEN_",",".01","I") ;ICR#: 6047 SDWL(409.32
..K CLIN1 D GETS^DIQ(44,PTR_",",".01;8","IE","CLIN1") S CLINNAME=$G(CLIN1(44,PTR_",",.01,"E")),STPCODE=$G(CLIN1(44,PTR_",",8,"E"))
.S SC=$G(SDWL1(409.3,REC_",",14,"E")),PRIOR1=$G(SDWL1(409.3,REC_",",10,"E")),ENRSTAT=$G(SDWL1(409.3,REC_",",27,"E")) ;ICR#: 6046 SDWL(409.3
.;S DTREMOVE=$P($G(^SDWL(409.3,REC,"SDAPT")),"^",1) ;ICR#: 6046 SDWL(409.3
.S DTREMOVE=$G(SDWL1(409.3,REC_",",13.1,"I")) ;ICR#: 6046 SDWL(409.3
.;I ENRSTAT1'="" S ENRSTAT=$S(ENRSTAT1="N":"NEW",ENRSTAT1="E":"ESTABLISHED",ENRSTAT1="P":"PRIOR",ENRSTAT1="U":"UNDETERMINED",1:"UNKNOWN")
.;I PRIOR'="" S PRIOR1=$S(PRIOR="A":"ASAP",PRIOR="F":"FUTURE",1:0)
.;S NODE=$G(^SDWL(409.3,REC,0)) ;ICR#: 6046 SDWL(409.3
.;Q:$G(NODE)=""
.;Q:$P($G(NODE),"^",17)="C"
.;D NOW^%DTC,DEM^VADPT,ADD^VADPT ;ICR#: 10061 VADPT
.;S (ORIGDT,LASTUPDT)=$P(NODE,"^",2),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
.;S PTNAME=$G(VADM(1)) ;,LASTNAME=$P(PTNAME,",")
.;S SSN=$P($G(VADM(2)),"^",2),ZIP=$G(VAPA(6))
.;S DESIRED=$P(NODE,"^",16),CLINIEN=$P(NODE,"^",9)
.;I $G(CLINIEN)'="" D
.;S SC=$P($G(^SDWL(409.3,REC,"SC")),"^",1),PRIOR=$P(NODE,"^",11),ENRSTAT1=$P(NODE,"^",20) ;ICR#: 6046 SDWL(409.3
.;S DTREMOVE=$P($G(^SDWL(409.3,REC,"SDAPT")),"^",1) ;ICR#: 6046 SDWL(409.3
.;I ENRSTAT1'="" S ENRSTAT=$S(ENRSTAT1="N":"NEW",ENRSTAT1="E":"ESTABLISHED",ENRSTAT1="P":"PRIOR",ENRSTAT1="U":"UNDETERMINED",1:"UNKNOWN")
.;I PRIOR'="" S PRIOR1=$S(PRIOR="A":"ASAP",PRIOR="F":"FUTURE",1:0)
.S RESULTS(CNT)=DFN_U_$G(STPCODE)_U_$G(LASTUPDT)_U_$G(PTNAME)_U_$G(SSN)_U_$G(CLINNAME)_U_$G(ORIGDT)_U_$G(DESIRED)_U_$G(DAYSON)_U_$G(DTREMOVE)_U_$G(ZIP)_U_$G(SC)_U_$G(ENRSTAT)_U_$G(PRIOR1)_U_$G(CLINIEN)_U_$G(REC),CNT=CNT+1
.D KVA^VADPT
.K NODE,%,ORIGDT,LASTUPDT,DAYSON,PTNAME,LASTNAME,SSN
.K DESIRED,CLINIEN,PTR,CLINNAME,STOPPTR,STPCODE,PRIOR,ENRSTAT,SC,ENRSTAT1,PRIOR1
K REC,CNT,REC,DFN
Q
EDITNEAR(RESULTS,DFN,STATUS,COMM) ;Edit a patient on the NEAR List MBAA RPC: MBAA UPDATE NEAR LIST
;Called by the RPC ZSD EDIT NEAR
;Input:
; DFN = Patient DFN
; STATUS = Set of codes:
; C = Cancelled
; E = EWL - Moved to the EWL
; F = Filled
; I = In Process/Veteran Contacted
; COMM = Comments. Required if the status is cancelled, otherwise it is optional
;Output: RESULTS(0)="0^Patient NEAR List entry updated." if the update was successful
; RESULTS(0)="1^Patient is not on the NEAR List."
; RESULTS(0)="1^DFN was not provided."
; RESULTS(0)="1^Status is null. Status is a required field."
; RESULTS(0)="1^Could not update the record."
; RESULTS(0)="1^Patient record is locked, try again later."
S RESULTS(0)=""
I $G(DFN)="" S RESULTS(0)="1^DFN was not provided." Q
I $G(STATUS)="" S RESULTS(0)="1^Status is null. Status is a required field." Q
I $D(^DPT(DFN,1010.16)) D ;ICR#: 6053 DPT
.I $P(^DPT(DFN,1010.16),U,1)'="" S ERR=1 ;ICR#: 6053 DPT
I $G(ERR)=1 S RESULTS(0)="1^Patient is not on the NEAR List." Q
I '$$GET1^DIQ(2,DFN,1010.159,"I") S RESULTS(0)="1^Patient is not on the NEAR List." Q
D NOW^%DTC
L +^DPT(DFN):10 I '$TEST S ERR=1,RESULTS(0)="1^Patient record is locked, try again later." Q ;ICR#: 6053 DPT
S DA=DFN,DIE="^DPT(",DR="1010.161///"_$G(STATUS)_";1010.163///"_$G(COMM) D ^DIE
L -^DPT(DFN) ;ICR#: 6053 DPT
K DA,DIE,DR
;I $P($G(^DPT(DFN,1010.16)),"^")='$G(STATUS) S ERR=1
;I $P($G(^DPT(DFN,1010.16)),"^",2)'=% S ERR=1
I $P($G(^DPT(DFN,1010.16)),"^")=$G(STATUS) S RESULTS(0)="0^Patient removed from NEAR List." ;ICR#: 6053 DPT
;I $G(ERR)=1 S RESULTS(0)="1^Could not update the record." Q
S RESULTS(0)="0^Patient NEAR List entry updated."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAARPCL 18534 printed Dec 13, 2024@02:15:03 Page 2
MBAARPCL ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
+1 ;;1.0;Scheduling Calendar View;**1**;Feb 10, 2016;Build 85
+2 ;
+3 ;Associated ICRs:
+4 ; ICR#
+5 ; 6045 SD(403.5
+6 ; 10061 VADPT
+7 ; 6044 SC(
+8 ; 10112 VASITE
+9 ; 6053 DPT
+10 ; 10103 XLFDT
+11 ; 6047 SDWL(409.32
+12 ; 1024 DIC(40.7
+13 ; 6046 SDWL(409.3
+14 ;
+15 ;This routine has multiple RPCs created to support the mobile Scheduling apps
RECALL(RESULTS) ;pull a list of recalls for a facility MBAA RPC: MBAA RECALL FACILITY LIST
+1 ; No input parameters
+2 ; Output: RESULTS Array:
+3 ; $P(1) = DFN
+4 ; $P(2) = PTR TO CLINIC FILE
+5 ; $P(3) = ACCESSION#
+6 ; $P(4) = TEST/APP - PTR TO FILE 403.51
+7 ; $P(5) = PROVIDER - PTR TO FILE 405.54
+8 ; $P(6) = RECALL DATE PER PROVIDER
+9 ; $P(7) = COMMENT
+10 ; $P(8) = FAST/NON-FASTING (SET OF CODES: f = Fasting, n = Non- Fasting)
+11 ; $P(9) = LENGTH OF APPOINTMENT
+12 ; $P(10) = DATE REMINDER SENT
+13 ; $P(11) = USER WHO ENTERED RECALL (PTR to file 200)
+14 ; $P(12) = RECALL DATE (PER PATIENT)
+15 ; $P(13) = SECOND PRINT DATE
+16 ; $P(14) = PATIENT NAME (LAST,FIRST)
+17 ; $P(15) = PATIENT SSN
+18 ; $P(16) = CLINIC NAME
+19 ;
+20 ;ICR#: 6045 SD(403.5
SET CNT=0
SET XX=0
FOR
SET XX=$ORDER(^SD(403.5,XX))
if XX'>0
QUIT
Begin DoDot:1
+21 KILL DFN,LNAME,SSN,CLINIC,CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT
+22 ;T13 Change to FM read
+23 ;S NODE=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
+24 ;S DFN=$P(NODE,"^"),CIEN=$P(NODE,"^",2)
+25 ;D DEM^VADPT ;ICR#: 10061 VADPT
+26 ;S LNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
+27 ;I $G(CIEN)>0 S CLINIC=$P(^SC(CIEN,0),"^") ;ICR#: 6044 SC(
+28 ;S ACCESS=$P(NODE,"^",3),TESTAPP=$P(NODE,"^",4),PROVIDER=$P(NODE,"^",5),RECALLDT=$P(NODE,"^",6)
+29 ;S COMMENT=$P(NODE,"^",7),FASTNON=$P(NODE,"^",8),APPTLEN=$P(NODE,"^",9),REMINDDT=$P(NODE,"^",10)
+30 ;S USER=$P(NODE,"^",11),PATRECDT=$P(NODE,"^",12),SECPRT=$P(NODE,"^",13)
+31 ;S RESULTS(CNT)=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
+32 NEW ARRAY
DO GETS^DIQ(403.5,$GET(XX),"**","IE","ARRAY")
+33 SET DFN=$GET(ARRAY(403.5,XX_",",.01,"I"))
SET LNAME=$GET(ARRAY(403.5,XX_",",.01,"E"))
SET CIEN=$GET(ARRAY(403.5,XX_",",4.5,"I"))
SET CLINIC=$GET(ARRAY(403.5,XX_",",4.5,"E"))
+34 DO DEM^VADPT
SET SSN=$PIECE($GET(VADM(2)),"^",2)
+35 SET ACCESS=$GET(ARRAY(403.5,XX_",",2,"I"))
SET TESTAPP=$GET(ARRAY(403.5,XX_",",3,"I"))
SET PROVIDER=$GET(ARRAY(403.5,XX_",",4,"I"))
SET RECALLDT=$GET(ARRAY(403.5,XX_",",5,"I"))
+36 SET COMMENT=$GET(ARRAY(403.5,XX_",",2.5,"I"))
SET FASTNON=$GET(ARRAY(403.5,XX_",",2.6,"I"))
SET APPTLEN=$GET(ARRAY(403.5,XX_",",4.7,"I"))
+37 SET REMINDDT=$GET(ARRAY(403.5,XX_",",6,"I"))
SET USER=$GET(ARRAY(403.5,XX_",",7,"I"))
SET PATRECDT=$GET(ARRAY(403.5,XX_",",5.5,"I"))
SET SECPRT=$GET(ARRAY(403.5,XX_",",8,"I"))
+38 SET RESULTS(CNT)=$GET(DFN)_U_$GET(CIEN)_U_$GET(ACCESS)_U_$GET(TESTAPP)_U_$GET(PROVIDER)_U_$GET(RECALLDT)_U_$GET(COMMENT)_U_$GET(FASTNON)_U_$GET(APPTLEN)_U_$GET(REMINDDT)_U_$GET(USER)_U_$GET(PATRECDT)_U_$GET(SECPRT)_U_$GET(LNAME)_U_...
... $GET(SSN)_U_$GET(CLINIC)
+39 ;S:$P(RESULTS(CNT),"^",13)="" RESULTS(CNT)=$G(RESULTS(CNT))_"^^"_$G(LNAME)_"^"_$G(SSN)_"^"_$G(CLINIC)
+40 SET CNT=CNT+1
+41 DO KVA^VADPT
End DoDot:1
+42 if $GET(RESULTS(0))=""
SET RESULTS(0)="1^RECALL LIST EMPTY"
+43 KILL XDT,XX,CNT,DFN,LNAME,VA("PID"),VA("BID"),SSN,CLINIC,CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT,SECPRT
+44 QUIT
RCLDFN(RESULTS,DFN) ;pull a list of recalls by patient MBAA RPC: MBAA RECALL LIST BY PATIENT
+1 ; Input parameter = DFN (PTR to Patient file #2)
+2 ; Output: RESULTS Array:
+3 ; $P(1) = DFN
+4 ; $P(2) = PTR TO CLINIC FILE
+5 ; $P(3) = ACCESSION#
+6 ; $P(4) = TEST/APP - PTR TO FILE 403.51
+7 ; $P(5) = PROVIDER - PTR TO FILE 405.54
+8 ; $P(6) = RECALL DATE PER PROVIDER
+9 ; $P(7) = COMMENT
+10 ; $P(8) = FAST/NON-FASTING (SET OF CODES: f = Fasting, n = Non- Fasting)
+11 ; $P(9) = LENGTH OF APPOINTMENT
+12 ; $P(10) = DATE REMINDER SENT
+13 ; $P(11) = USER WHO ENTERED RECALL (PTR to file 200)
+14 ; $P(12) = RECALL DATE (PER PATIENT)
+15 ; $P(13) = SECOND PRINT DATE
+16 ; $P(14) = PATIENT NAME (LAST,FIRST)
+17 ; $P(15) = PATIENT SSN
+18 ; $P(16) = CLINIC NAME
+19 ;
+20 KILL RESULTS
+21 IF $GET(DFN)=""
SET RESULTS(0)="1^DFN HAS TO BE SUPPLIED"
QUIT
+22 SET RESULTS(0)="1^RECALL LIST EMPTY"
+23 ;ICR#: 6045 SD(403.5
SET CNT=0
SET XX=0
FOR
SET XX=$ORDER(^SD(403.5,"B",DFN,XX))
if XX'>0
QUIT
Begin DoDot:1
+24 KILL LNAME,SSN,CLINIC,CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT
+25 ;T13 Change to FM read
+26 ;S NODE=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
+27 ;S CIEN=$P(NODE,"^",2)
+28 ;D DEM^VADPT ;ICR#: 10061 VADPT
+29 ;S LNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
+30 ;I $G(CIEN)>0 S CLINIC=$P(^SC(CIEN,0),"^") ;ICR#: 6044 SC(
+31 ;S ACCESS=$P(NODE,"^",3),TESTAPP=$P(NODE,"^",4),PROVIDER=$P(NODE,"^",5),RECALLDT=$P(NODE,"^",6)
+32 ;S COMMENT=$P(NODE,"^",7),FASTNON=$P(NODE,"^",8),APPTLEN=$P(NODE,"^",9),REMINDDT=$P(NODE,"^",10)
+33 ;S USER=$P(NODE,"^",11),PATRECDT=$P(NODE,"^",12),SECPRT=$P(NODE,"^",13)
+34 ;S RESULTS(CNT)=$G(^SD(403.5,XX,0)) ;ICR#: 6045 SD(403.5
+35 NEW ARRAY
DO GETS^DIQ(403.5,$GET(XX),"**","IE","ARRAY")
+36 SET DFN=$GET(ARRAY(403.5,XX_",",.01,"I"))
SET LNAME=$GET(ARRAY(403.5,XX_",",.01,"E"))
SET CIEN=$GET(ARRAY(403.5,XX_",",4.5,"I"))
SET CLINIC=$GET(ARRAY(403.5,XX_",",4.5,"E"))
+37 DO DEM^VADPT
SET SSN=$PIECE($GET(VADM(2)),"^",2)
+38 SET ACCESS=$GET(ARRAY(403.5,XX_",",2,"I"))
SET TESTAPP=$GET(ARRAY(403.5,XX_",",3,"I"))
SET PROVIDER=$GET(ARRAY(403.5,XX_",",4,"I"))
SET RECALLDT=$GET(ARRAY(403.5,XX_",",5,"I"))
+39 SET COMMENT=$GET(ARRAY(403.5,XX_",",2.5,"I"))
SET FASTNON=$GET(ARRAY(403.5,XX_",",2.6,"I"))
SET APPTLEN=$GET(ARRAY(403.5,XX_",",4.7,"I"))
+40 SET REMINDDT=$GET(ARRAY(403.5,XX_",",6,"I"))
SET USER=$GET(ARRAY(403.5,XX_",",7,"I"))
SET PATRECDT=$GET(ARRAY(403.5,XX_",",5.5,"I"))
SET SECPRT=$GET(ARRAY(403.5,XX_",",8,"I"))
+41 SET RESULTS(CNT)=$GET(DFN)_U_$GET(CIEN)_U_$GET(ACCESS)_U_$GET(TESTAPP)_U_$GET(PROVIDER)_U_$GET(RECALLDT)_U_$GET(COMMENT)_U_$GET(FASTNON)_U_$GET(APPTLEN)_U_$GET(REMINDDT)_U_$GET(USER)_U_$GET(PATRECDT)_U_$GET(SECPRT)_U_$GET(LNAME)_U_...
... $GET(SSN)_U_$GET(CLINIC)
+42 ;S RESULTS(CNT)=$G(^SD(403.5,XX,0))
+43 ;S:$P(RESULTS(CNT),"^",13)="" RESULTS(CNT)=$G(RESULTS(CNT))_"^"
+44 SET CNT=CNT+1
+45 DO KVA^VADPT
End DoDot:1
+46 KILL XDT,XX,CNT
+47 KILL DFN,LNAME,SSN,CLINIC,VA("PID"),VA("BID"),CIEN,NODE,ACCESS,COMMENT,USER,TESTAPP,FASTNON,PATRECDT,PROVIDER,APPTLEN,SCEPRT,RECALLDT,REMINDDT
+48 QUIT
NEARLST(RESULTS) ;Gets the NEAR List for a Facility MBAA RPC: MBAA FACILITY NEAR LIST
+1 ; No input parameters required
+2 ; Output: TMP($J,"NEAR")=DFN^PATIENTNAME^SSN^ELIGIBILITY CODE INTERNAL^ELIGIBILITY CODE EXTERNAL^HOME PHONE^CELL PHONE^DATE^SITE
+3 ; DFN = PATIENT ID
+4 ; PATIENTNAME = PATIENT NAME
+5 ; SSN = LAST FOUR OF SSN
+6 ; ELIGIBILITY CODE INTERNAL = INTERNAL ELIGIBILITY CODE
+7 ; ELIGIBILITY CODE EXTERNAL = EXTERNAL ELIGIBILITY CODE
+8 ; HOME PHONE
+9 ; CELL PHONE
+10 ; DATE = APPOINTMENT DATE REQUESTED
+11 ; SITE = FACILITY ID
+12 ;-Build temp global
+13 KILL ^TMP($JOB,"NEAR")
+14 NEW DFNIEN,DGSITE,PNAME,SSN,ELIG,PHONE,CELL,DFN
+15 ;ICR#: 10112 VASITE
SET DGSITE=+$$SITE^VASITE()
+16 ;ICR#: 6053 DPT
SET (CNT,DFNIEN)=0
FOR
SET DFNIEN=$ORDER(^DPT("AEAR",1,DFNIEN))
if 'DFNIEN
QUIT
Begin DoDot:1
+17 IF $$GET1^DIQ(2,DFNIEN,1010.159,"I")
Begin DoDot:2
End DoDot:2
+18 ;ICR#: 6053 DPT
if $PIECE($GET(^DPT(DFNIEN,1010.16)),"^",1)'=""
QUIT
+19 ;ICR#: 10061 VADPT
SET DFN=DFNIEN
DO DEM^VADPT
DO ELIG^VADPT
DO ADD^VADPT
+20 SET CNT=CNT+1
+21 ;T13 Change to get cell phone using FM read
+22 ;S PNAME=VADM(1),SSN=+VADM(2),ELIG=VAEL(1),PHONE=VAPA(8),CELL=$P($G(^DPT(DFNIEN,.13)),"^",4) ;ICR#: 6053 DPT
+23 ;ICR#: 6053 DPT
SET PNAME=VADM(1)
SET SSN=+VADM(2)
SET ELIG=VAEL(1)
SET PHONE=VAPA(8)
SET CELL=$$GET1^DIQ(2,100841,.01,"I")
+24 IF $GET(ELIG)=""
SET ELIG="^"
+25 SET ^TMP($JOB,"NEAR",CNT)=DFNIEN_"^"_$GET(PNAME)_"^"_$GET(SSN)_"^"_$GET(ELIG)_"^"_$GET(PHONE)_"^"_$GET(CELL)_"^"_$$GET1^DIQ(2,DFNIEN,1010.1511,"I")_"^"_DGSITE_$CHAR(10)
+26 KILL PNAME,DFN,SSN,ELIG,PHONE,CELL
+27 DO KVA^VADPT
End DoDot:1
+28 SET RESULTS=$NAME(^TMP($JOB,"NEAR"))
+29 KILL DFN,VADM,VAEL,VAPA,VA("BID"),VA("PID"),VACNTRY,VAERR
+30 QUIT
+31 ;
NEARDFN(RESULTS,DFN) ;Gets the NEAR List for a PATIENT MBAA RPC: MBAA PATIENT NEAR LIST
+1 ; INPUT: Patient DFN
+2 ; Output:
+3 ; If the patient is on the NEAR List, returns the array:
+4 ; DFN^PATIENTNAME^SSN^ELIGIBILITY CODE INTERNAL^ELIGIBILITY CODE EXTERNAL^HOME PHONE^CELL PHONE^DATE^SITE
+5 ; DFN = PATIENT ID
+6 ; PATIENTNAME = PATIENT NAME
+7 ; SSN = LAST FOUR OF SSN
+8 ; ELIGIBILITY CODE INTERNAL = INTERNAL ELIGIBILITY CODE
+9 ; ELIGIBILITY CODE EXTERNAL = EXTERNAL ELIGIBILITY CODE
+10 ; HOME PHONE
+11 ; CELL PHONE
+12 ; DATE = APPOINTMENT DATE REQUESTED
+13 ; SITE = FACILITY ID
+14 ; If the patient is not on the NEAR List returns "1^Patient not on the NEAR List"
+15 NEW DGSITE,SSN,ELIG,PHONE,CELL,PNAME
+16 IF $GET(DFN)=""
SET RESULTS(0)="1^DFN IS NOT DEFINED"
QUIT
+17 SET RESULTS(0)=""
+18 IF $$GET1^DIQ(2,DFN,1010.159,"I")
Begin DoDot:1
+19 ;ICR#: 6053 DPT
if $PIECE($GET(^DPT(DFN,1010.16)),"^",1)'=""
QUIT
+20 SET DGSITE=+$$SITE^VASITE()
+21 ;ICR#: 10061 VADPT
DO DEM^VADPT
DO ELIG^VADPT
DO ADD^VADPT
+22 ;T13 Change to get cell phone using FM read
+23 ;S PNAME=VADM(1),SSN=+VADM(2),ELIG=VAEL(1),PHONE=VAPA(8),CELL=$P($G(^DPT(DFN,.13)),"^",4) ;ICR#: 6053 DPT
+24 ;ICR#: 6053 DPT
SET PNAME=VADM(1)
SET SSN=+VADM(2)
SET ELIG=VAEL(1)
SET PHONE=VAPA(8)
SET CELL=$$GET1^DIQ(2,100841,.01,"I")
+25 IF $GET(ELIG)=""
SET ELIG="^"
+26 SET RESULTS(0)=DFN_"^"_$GET(PNAME)_"^"_$GET(SSN)_"^"_$GET(ELIG)_"^"_$GET(PHONE)_"^"_$GET(CELL)_"^"_$$GET1^DIQ(2,DFN,1010.1511,"I")_"^"_DGSITE
+27 DO KVA^VADPT
End DoDot:1
+28 IF RESULTS(0)=""
SET RESULTS(0)="1^Patient not on the NEAR List"
+29 KILL DFN,VADM,VAEL,VAPA,VA("BID"),VA("PID"),VACNTRY,VAERR
+30 QUIT
EWL(RESULTS,DFN) ; gets the EWL data by patient as described in the output data MBAA RPC: MBAA WAIT LIST BY DFN
+1 ; Input: Patient DFN (PTR to Patient File (#2))
+2 ; Outputs if successful - patient is on the EWL:
+3 ; $P(1) = DFN
+4 ; $P(2) = DSS STOP CODE
+5 ; $P(3) = LAST UPDATED (RETURNED IN FILEMAN FORMAT)
+6 ; $P(4) = PATIENT NAME
+7 ; $P(5) = PATIENT SSN
+8 ; $P(6) = CLINIC NAME
+9 ; $P(7) = ORIGINATING DATE (RETURNED IN FILEMAN FORMAT)
+10 ; $P(8) = DESIRED DATE OF APPOINTMENT
+11 ; $P(9) = DAYS ON EWL
+12 ; $P(10) = DATE REMOVED FROM EWL (RETURNED IN FILEMAN FORMAT)
+13 ; $P(11) = PATIENT ZIP CODE
+14 ; $P(12) = SERVICE CONNECTED %
+15 ; $P(13) = ENROLLEE STATUS
+16 ; $P(14) = PRIORITY
+17 ; $P(15) = CLINIC ID
+18 ; $P(16) = IEN FROM SDWL(409.3 FOR THE ENTRY
+19 ;
+20 ; If patient is not on the EWL, returns
+21 ; RESULTS(0)="1^PATIENT NOT ON THE EWL."
+22 ;
+23 IF $GET(DFN)=""
SET RESULTS(0)="1^DFN IS NOT DEFINED"
QUIT
+24 ;ICR#: 6046 SDWL(409.3
IF '$DATA(^SDWL(409.3,"B",DFN))
SET RESULTS(0)="1^PATIENT NOT ON THE EWL"
QUIT
+25 ;ICR#: 6046 SDWL(409.3
SET REC=0
SET CNT=1
FOR
SET REC=$ORDER(^SDWL(409.3,"B",DFN,REC))
if REC'>0
QUIT
Begin DoDot:1
+26 ;T13 Change to use FM reads
+27 ;S NODE=$G(^SDWL(409.3,REC,0)) ;ICR#: 6046 SDWL(409.3
+28 ;Q:$G(NODE)=""
+29 ;I $P($G(NODE),"^",17)="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
+30 ;I $P($G(NODE),"^",17)="O" S RESULTS(0)=""
+31 IF $$GET1^DIQ(409.3,REC,23,"I")="C"
SET RESULTS(0)="1^PATIENT NOT ON THE EWL"
QUIT
+32 IF $$GET1^DIQ(409.3,REC,23,"I")="O"
SET RESULTS(0)=""
+33 NEW SDWL1
+34 DO GETS^DIQ(409.3,REC_",","1;8;10;13.1;14;22;23;27","IE","SDWL1")
+35 ;ICR#: 10061 VADPT
DO NOW^%DTC
DO DEM^VADPT
DO ADD^VADPT
+36 ;ICR#: 10103 XLFDT
SET (ORIGDT,LASTUPDT)=$GET(SDWL1(409.3,REC_",",1,"I"))
SET DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1)
+37 ;S (ORIGDT,LASTUPDT)=$P(NODE,"^",2),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
+38 ;,LASTNAME=$P(PTNAME,",")
SET PTNAME=$GET(VADM(1))
+39 SET SSN=$PIECE($GET(VADM(2)),"^",2)
SET ZIP=$GET(VAPA(6))
+40 SET DESIRED=$GET(SDWL1(409.3,REC_",",22,"I"))
SET CLINIEN=$GET(SDWL1(409.3,REC_",",8,"I"))
+41 ;S DESIRED=$P(NODE,"^",16),CLINIEN=$P(NODE,"^",9)
+42 IF $GET(CLINIEN)'=""
Begin DoDot:2
+43 ;ICR#: 6047 SDWL(409.32
SET PTR=$$GET1^DIQ(409.32,CLINIEN_",",".01","I")
+44 KILL CLIN1
DO GETS^DIQ(44,PTR_",",".01;8","IE","CLIN1")
SET CLINNAME=$GET(CLIN1(44,PTR_",",.01,"E"))
SET STPCODE=$GET(CLIN1(44,PTR_",",8,"E"))
End DoDot:2
+45 ;S SC=$P($G(^SDWL(409.3,REC,"SC")),"^",1),PRIOR=$P(NODE,"^",11),ENRSTAT1=$P(NODE,"^",20) ;ICR#: 6046 SDWL(409.3
+46 ;ICR#: 6046 SDWL(409.3
SET SC=$GET(SDWL1(409.3,REC_",",14,"E"))
SET PRIOR1=$GET(SDWL1(409.3,REC_",",10,"E"))
SET ENRSTAT=$GET(SDWL1(409.3,REC_",",27,"E"))
+47 ;S DTREMOVE=$P($G(^SDWL(409.3,REC,"SDAPT")),"^",1) ;ICR#: 6046 SDWL(409.3
+48 ;ICR#: 6046 SDWL(409.3
SET DTREMOVE=$GET(SDWL1(409.3,REC_",",13.1,"I"))
+49 ;I ENRSTAT1'="" S ENRSTAT=$S(ENRSTAT1="N":"NEW",ENRSTAT1="E":"ESTABLISHED",ENRSTAT1="P":"PRIOR",ENRSTAT1="U":"UNDETERMINED",1:"UNKNOWN")
+50 ;I PRIOR'="" S PRIOR1=$S(PRIOR="A":"ASAP",PRIOR="F":"FUTURE",1:0)
+51 SET RESULTS(CNT)=DFN_U_$GET(STPCODE)_U_$GET(LASTUPDT)_U_$GET(PTNAME)_U_$GET(SSN)_U_$GET(CLINNAME)_U_$GET(ORIGDT)_U_$GET(DESIRED)_U_$GET(DAYSON)_U_$GET(DTREMOVE)_U_$GET(ZIP)_U_$GET(SC)_U_$GET(ENRSTAT)_U_$GET(PRIOR1)_U_$GET(CLINIEN)_U_$GE
T(REC)
SET CNT=CNT+1
+52 DO KVA^VADPT
+53 KILL NODE,%,ORIGDT,LASTUPDT,DAYSON,PTNAME,LASTNAME,SSN
+54 KILL DESIRED,CLINIEN,PTR,CLINNAME,STOPPTR,STPCODE,PRIOR,ENRSTAT,SC,ENRSTAT1,PRIOR1,DTREMOVE,ZIP,CLIN1,SDWL1
End DoDot:1
+55 KILL REC,CNT,REC,DFN
+56 QUIT
FACEWL(RESULTS) ; gets the EWL data for a facility as described in the output data MBAA RPC: MBAA FACILITY WAIT LIST
+1 ; Outputs if successful - patient is on the EWL:
+2 ; $P(1) = DFN
+3 ; $P(2) = DSS STOP CODE
+4 ; $P(3) = LAST UPDATED (RETURNED IN FILEMAN FORMAT)
+5 ; $P(4) = PATIENT NAME
+6 ; $P(5) = PATIENT SSN
+7 ; $P(6) = CLINIC NAME
+8 ; $P(7) = ORIGINATING DATE (RETURNED IN FILEMAN FORMAT)
+9 ; $P(8) = DESIRED DATE OF APPOINTMENT
+10 ; $P(9) = DAYS ON EWL
+11 ; $P(10) = DATE REMOVED FROM EWL (RETURNED IN FILEMAN FORMAT)
+12 ; $P(11) = PATIENT ZIP CODE
+13 ; $P(12) = SERVICE CONNECTED %
+14 ; $P(13) = ENROLLEE STATUS
+15 ; $P(14) = PRIORITY
+16 ; $P(15) = CLINIC ID
+17 ; $P(16) = IEN FROM SDWL(409.3 FOR THE ENTRY
+18 ;
+19 ; If no patients are not on the EWL, returns
+20 ; RESULTS(0)="1^EWL is empty."
+21 ;
+22 ;ICR#: 6046 SDWL(409.3
IF '$DATA(^SDWL(409.3,"B"))
SET RESULTS(0)="1^EWL is empty."
QUIT
+23 ;ICR#: 6046 SDWL(409.3
SET REC=0
SET CNT=0
SET DFN=0
FOR
SET DFN=$ORDER(^SDWL(409.3,"B",DFN))
if DFN'>0
QUIT
FOR
SET REC=$ORDER(^SDWL(409.3,"B",DFN,REC))
if REC'>0
QUIT
Begin DoDot:1
+24 ;T13 Change to use FM reads
+25 ;S NODE=$G(^SDWL(409.3,REC,0)) ;ICR#: 6046 SDWL(409.3
+26 ;Q:$G(NODE)=""
+27 ;I $P($G(NODE),"^",17)="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
+28 ;I $P($G(NODE),"^",17)="O" S RESULTS(0)=""
+29 ;I $$GET1^DIQ(409.3,REC,23,"I")="C" S RESULTS(0)="1^PATIENT NOT ON THE EWL" Q
+30 ;I $$GET1^DIQ(409.3,REC,23,"I")="O" S RESULTS(0)=""
+31 if $$GET1^DIQ(409.3,REC,23,"I")="C"
QUIT
+32 NEW SDWL1
+33 KILL SEWL1
DO GETS^DIQ(409.3,REC_",","1;8;10;13.1;14;22;23;27","IE","SDWL1")
+34 ;ICR#: 10061 VADPT
DO NOW^%DTC
DO DEM^VADPT
DO ADD^VADPT
+35 ;ICR#: 10103 XLFDT
SET (ORIGDT,LASTUPDT)=$GET(SDWL1(409.3,REC_",",1,"I"))
SET DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1)
+36 ;S (ORIGDT,LASTUPDT)=$P(NODE,"^",2),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
+37 ;,LASTNAME=$P(PTNAME,",")
SET PTNAME=$GET(VADM(1))
+38 SET SSN=$PIECE($GET(VADM(2)),"^",2)
SET ZIP=$GET(VAPA(6))
+39 SET DESIRED=$GET(SDWL1(409.3,REC_",",22,"I"))
SET CLINIEN=$GET(SDWL1(409.3,REC_",",8,"I"))
+40 ;S DESIRED=$P(NODE,"^",16),CLINIEN=$P(NODE,"^",9)
+41 IF $GET(CLINIEN)'=""
Begin DoDot:2
+42 ;ICR#: 6047 SDWL(409.32
SET PTR=$$GET1^DIQ(409.32,CLINIEN_",",".01","I")
+43 KILL CLIN1
DO GETS^DIQ(44,PTR_",",".01;8","IE","CLIN1")
SET CLINNAME=$GET(CLIN1(44,PTR_",",.01,"E"))
SET STPCODE=$GET(CLIN1(44,PTR_",",8,"E"))
End DoDot:2
+44 ;ICR#: 6046 SDWL(409.3
SET SC=$GET(SDWL1(409.3,REC_",",14,"E"))
SET PRIOR1=$GET(SDWL1(409.3,REC_",",10,"E"))
SET ENRSTAT=$GET(SDWL1(409.3,REC_",",27,"E"))
+45 ;S DTREMOVE=$P($G(^SDWL(409.3,REC,"SDAPT")),"^",1) ;ICR#: 6046 SDWL(409.3
+46 ;ICR#: 6046 SDWL(409.3
SET DTREMOVE=$GET(SDWL1(409.3,REC_",",13.1,"I"))
+47 ;I ENRSTAT1'="" S ENRSTAT=$S(ENRSTAT1="N":"NEW",ENRSTAT1="E":"ESTABLISHED",ENRSTAT1="P":"PRIOR",ENRSTAT1="U":"UNDETERMINED",1:"UNKNOWN")
+48 ;I PRIOR'="" S PRIOR1=$S(PRIOR="A":"ASAP",PRIOR="F":"FUTURE",1:0)
+49 ;S NODE=$G(^SDWL(409.3,REC,0)) ;ICR#: 6046 SDWL(409.3
+50 ;Q:$G(NODE)=""
+51 ;Q:$P($G(NODE),"^",17)="C"
+52 ;D NOW^%DTC,DEM^VADPT,ADD^VADPT ;ICR#: 10061 VADPT
+53 ;S (ORIGDT,LASTUPDT)=$P(NODE,"^",2),DAYSON=$$FMDIFF^XLFDT(%,ORIGDT,1) ;ICR#: 10103 XLFDT
+54 ;S PTNAME=$G(VADM(1)) ;,LASTNAME=$P(PTNAME,",")
+55 ;S SSN=$P($G(VADM(2)),"^",2),ZIP=$G(VAPA(6))
+56 ;S DESIRED=$P(NODE,"^",16),CLINIEN=$P(NODE,"^",9)
+57 ;I $G(CLINIEN)'="" D
+58 ;S SC=$P($G(^SDWL(409.3,REC,"SC")),"^",1),PRIOR=$P(NODE,"^",11),ENRSTAT1=$P(NODE,"^",20) ;ICR#: 6046 SDWL(409.3
+59 ;S DTREMOVE=$P($G(^SDWL(409.3,REC,"SDAPT")),"^",1) ;ICR#: 6046 SDWL(409.3
+60 ;I ENRSTAT1'="" S ENRSTAT=$S(ENRSTAT1="N":"NEW",ENRSTAT1="E":"ESTABLISHED",ENRSTAT1="P":"PRIOR",ENRSTAT1="U":"UNDETERMINED",1:"UNKNOWN")
+61 ;I PRIOR'="" S PRIOR1=$S(PRIOR="A":"ASAP",PRIOR="F":"FUTURE",1:0)
+62 SET RESULTS(CNT)=DFN_U_$GET(STPCODE)_U_$GET(LASTUPDT)_U_$GET(PTNAME)_U_$GET(SSN)_U_$GET(CLINNAME)_U_$GET(ORIGDT)_U_$GET(DESIRED)_U_$GET(DAYSON)_U_$GET(DTREMOVE)_U_$GET(ZIP)_U_$GET(SC)_U_$GET(ENRSTAT)_U_$GET(PRIOR1)_U_$GET(CLINIEN)_U
_$GET(REC)
SET CNT=CNT+1
+63 DO KVA^VADPT
+64 KILL NODE,%,ORIGDT,LASTUPDT,DAYSON,PTNAME,LASTNAME,SSN
+65 KILL DESIRED,CLINIEN,PTR,CLINNAME,STOPPTR,STPCODE,PRIOR,ENRSTAT,SC,ENRSTAT1,PRIOR1
End DoDot:1
+66 KILL REC,CNT,REC,DFN
+67 QUIT
EDITNEAR(RESULTS,DFN,STATUS,COMM) ;Edit a patient on the NEAR List MBAA RPC: MBAA UPDATE NEAR LIST
+1 ;Called by the RPC ZSD EDIT NEAR
+2 ;Input:
+3 ; DFN = Patient DFN
+4 ; STATUS = Set of codes:
+5 ; C = Cancelled
+6 ; E = EWL - Moved to the EWL
+7 ; F = Filled
+8 ; I = In Process/Veteran Contacted
+9 ; COMM = Comments. Required if the status is cancelled, otherwise it is optional
+10 ;Output: RESULTS(0)="0^Patient NEAR List entry updated." if the update was successful
+11 ; RESULTS(0)="1^Patient is not on the NEAR List."
+12 ; RESULTS(0)="1^DFN was not provided."
+13 ; RESULTS(0)="1^Status is null. Status is a required field."
+14 ; RESULTS(0)="1^Could not update the record."
+15 ; RESULTS(0)="1^Patient record is locked, try again later."
+16 SET RESULTS(0)=""
+17 IF $GET(DFN)=""
SET RESULTS(0)="1^DFN was not provided."
QUIT
+18 IF $GET(STATUS)=""
SET RESULTS(0)="1^Status is null. Status is a required field."
QUIT
+19 ;ICR#: 6053 DPT
IF $DATA(^DPT(DFN,1010.16))
Begin DoDot:1
+20 ;ICR#: 6053 DPT
IF $PIECE(^DPT(DFN,1010.16),U,1)'=""
SET ERR=1
End DoDot:1
+21 IF $GET(ERR)=1
SET RESULTS(0)="1^Patient is not on the NEAR List."
QUIT
+22 IF '$$GET1^DIQ(2,DFN,1010.159,"I")
SET RESULTS(0)="1^Patient is not on the NEAR List."
QUIT
+23 DO NOW^%DTC
+24 ;ICR#: 6053 DPT
LOCK +^DPT(DFN):10
IF '$TEST
SET ERR=1
SET RESULTS(0)="1^Patient record is locked, try again later."
QUIT
+25 SET DA=DFN
SET DIE="^DPT("
SET DR="1010.161///"_$GET(STATUS)_";1010.163///"_$GET(COMM)
DO ^DIE
+26 ;ICR#: 6053 DPT
LOCK -^DPT(DFN)
+27 KILL DA,DIE,DR
+28 ;I $P($G(^DPT(DFN,1010.16)),"^")='$G(STATUS) S ERR=1
+29 ;I $P($G(^DPT(DFN,1010.16)),"^",2)'=% S ERR=1
+30 ;ICR#: 6053 DPT
IF $PIECE($GET(^DPT(DFN,1010.16)),"^")=$GET(STATUS)
SET RESULTS(0)="0^Patient removed from NEAR List."
+31 ;I $G(ERR)=1 S RESULTS(0)="1^Could not update the record." Q
+32 SET RESULTS(0)="0^Patient NEAR List entry updated."
+33 QUIT
