- 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 Apr 23, 2025@18:29:22 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
