Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MBAARPC3

MBAARPC3.m

Go to the documentation of this file.
  1. MBAARPC3 ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
  1. ;;1.0;Scheduling Calendar View;**1**;Feb 13, 2015;Build 85
  1. ;
  1. ;Associated ICRs:
  1. ; ICR#
  1. ; 6044 SC(
  1. ;
  1. ;This routine has multiple RPCs created to support the mobile Scheduling apps
  1. ;Line Tag ADMITS commented out due to the descoping the functionality in the first release
  1. ;ADMITS(RESULTS,DFN) ;Returns all admisssions for a patient MBAA RPC: MBAA PATIENT ADMISSIONS
  1. ;Input parameter: Patient DFN
  1. ;Returns:
  1. ; if admissions are found returns an array in the format of:
  1. ; RESULTS(0)=Discharge flag (0 = admitted, 1 = discharged)^Admission date^reason for admission^primary provider^attending physician^length of stay^ward^room-bed^treating specialty^date of discharge^type of discharge
  1. ; if no admissions are found for the patient in the last year
  1. ; Returns:
  1. ; RESULTS(INC)="0^No admissions"
  1. ; Returns the following errors:
  1. ; RESULTS(0)="0^DFN Missing"
  1. ; RESULTS(0)="0^Not a patient at this facility"
  1. ;
  1. ;K MOVEDT,DTFLG
  1. ;I $G(DFN)'>0 S RESULTS(0)="0^DFN Missing" Q
  1. ;I '$D(^DPT($G(DFN),0)) S RESULTS(0)="0^Not a patient at this facility" Q
  1. ;I '$D(^DGPM("APTT1",DFN)) S RESULTS(0)="0^Patient has not been admitted at this facility" Q ;ICR#: 565 DGPM("APTT1"
  1. ;D NOW^%DTC S MOVEDT=$$FMADD^XLFDT(%,-366,0,0,0),INC=1,DTFLG=0 ; removed customer wants all admissions
  1. ;S MOVEDT="",INC=1,DTFLG=0
  1. ;I $D(^DGPM("APTT1",DFN)) D CHKDT
  1. ;I DTFLG=1 S RESULTS(0)="0^Patient has not been admitted at this facility in the last year." Q
  1. ;F S MOVEDT=$O(^DGPM("APTT1",DFN,MOVEDT)) Q:MOVEDT'>0 S REC=0 F S REC=$O(^DGPM("APTT1",DFN,MOVEDT,REC)) Q:REC'>0 D
  1. ;.;K NODE,W1,WARD,RM1,RMBED,P1,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN,ADMITS
  1. ;.;S NODE=$G(^DGPM(REC,0)),ADFLG=0
  1. ;.;S ADFLG=0
  1. ;.;D GETS^DIQ(405,REC,".04;.06;.07;.08;.09;.1;.17;.19","IE","ADMITS")
  1. ;.;S W1=$P(NODE,"^",6) S:$G(W1)>0 WARD=$P(^DIC(42,W1,0),"^") ;ICR#: 10039
  1. ;.;S WARD=$G(ADMITS(405,REC_",",.06,"E"))
  1. ;.;S RM1=$P(NODE,"^",7) S:$G(RM1)>0 RMBED=$P(^DG(405.4,RM1,0),"^") ;ICR#: 1380 DG(405.4
  1. ;.;S RMBED=$G(ADMITS(405,REC_",",.07,"E"))
  1. ;.;S (DGPP,DGAP)="" D NOW^%DTC S NOWI=9999999.999999-% K %
  1. ;.;F I=NOWI:0 S I=$O(^DGPM("ATS",DFN,REC,I)) Q:'I F J=0:0 S J=$O(^DGPM("ATS",DFN,REC,I,J)) Q:'J F IFN=0:0 S IFN=$O(^DGPM("ATS",DFN,REC,I,J,IFN)) Q:'IFN D TS1 ;ICR#: 419 DGPM(
  1. ;.;S S1=$P(NODE,"^",9) S:$G(S1)>0 TRSPCLTY=$P(^DIC(45.7,S1,0),"^") ;ICR#: 362
  1. ;.;S TRSPCLTY=$G(ADMITS(405,REC_",",.09,"E"))
  1. ;.;S SHRTDIAG=$P(NODE,"^",10)
  1. ;.;S SHRTDIAG=$G(ADMITS(405,REC_",",.1,"E"))
  1. ;.;S DISFLAG=$P(NODE,"^",17)
  1. ;.;S DISFLAG=$G(ADMITS(405,REC_",",.17,"I"))
  1. ;.;I $G(DISFLAG)>0 S ADFLG=1,DISDATE=$P(^DGPM($G(DISFLAG),0),"^"),R1=$P(^DGPM($G(DISFLAG),0),"^",4),TYPEDIS=$P(^DG(405.1,R1,0),"^"),STAYLEN=$$FMDIFF^XLFDT(DISDATE,MOVEDT,1) ;ICR#: 10103 XLFDT, 2965 DG(405.1
  1. ;.;I $G(DISFLAG)>0 W !,$G(DISFLAG) S ADFLG=1,DISDATE=$P(^DGPM($G(DISFLAG),0),"^"),R1=$P(^DGPM($G(DISFLAG),0),"^",4),TYPEDIS=$G(ADMITS(405,REC_",",.04,"E")),STAYLEN=$$FMDIFF^XLFDT(DISDATE,MOVEDT,1) ;ICR#: 10103 XLFDT, 2965 DG(405.1
  1. ;.;S RESULTS(INC)=$G(ADFLG)_"^"_MOVEDT_"^"_$G(SHRTDIAG)_"^"_$G(PROVIDER)_"^"_$G(ATENDING)_"^"_$G(STAYLEN)_"^"_$G(WARD)_"^"_$G(RMBED)_"^"_$G(TRSPCLTY)_"^"_$G(DISDATE)_"^"_$G(TYPEDIS),INC=$G(INC)+1
  1. ;.;K NODE,W1,WARD,RM1,RMBED,P1,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN
  1. ;K MOVEDT,DFN,NODE,W1,I,IFN,INC,J,WARD,RM1,RMBED,P1,NOWI,REC,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN,DTFLG,ADMITS
  1. ;Q
  1. ;T13 Change to remove the linetag TS1 as it is not used in the first release of SCV
  1. ;TS1 ;
  1. ;N ADMITS1
  1. ;D GETS^DIQ(405,IFN,".08;.19","IE","ADMITS1")
  1. ;S PROVIDER=$G(ADMITS1(405,IFN_",",.08,"E")),ATENDING=$G(ADMITS1(405,IFN_",",.19,"E"))
  1. ;K PROVIDER,ATENDING
  1. ;Q
  1. GETPROV(PROV1,CLINID) ; Get a list of providers by clinic - RPC MBAA PROVIDERS BY CLINIC
  1. ; RPC MBAA PROVIDERS BY CLINIC
  1. ; INPUT PARAMETER: CLINIC ID - IEN for the clinic in the HOSPITAL LOCATION File (#44)
  1. ; OUTPUT: Array of providers in the format
  1. ; Success: ARRAY(I)=DFN^PROVIDER NAME
  1. ; Failure: ARRAY(0)="0^ERROR CODE"
  1. ;
  1. N ERR,CLINIC
  1. I $G(CLINID)="" S PROV1(1)="0^CLINIC ID IS NULL" Q
  1. S CLINIC=$$GET1^DIQ(44,CLINID,.01) I $G(CLINIC)="" S PROV1(1)="0^CLINIC DOESN'T EXIST" Q ;ICR#: 6044 SC(
  1. D GETS^DIQ(44,$G(CLINID),"2600*","IE","PROV")
  1. S CNT=1,XX="" F S XX=$O(PROV(44.1,XX)) Q:XX="" D
  1. .K PIEN,PNAME
  1. .S PIEN=$G(PROV(44.1,XX,.01,"I")),PNAME=$G(PROV(44.1,XX,.01,"E"))
  1. .I $G(PIEN)>0 S PROV1(CNT)=$G(PIEN)_"^"_$G(PNAME),CNT=CNT+1
  1. .K PIEN,PNAME
  1. K CNT,CLINID,CLINIC,XX,PROV,PIEN,PNAME
  1. I $G(PROV1(1))="" S PROV1(1)="NO PROVIDERS ASSIGNED TO THE CLINIC"
  1. Q