MBAARPC3 ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
;;1.0;Scheduling Calendar View;**1**;Feb 13, 2015;Build 85
;
;Associated ICRs:
; ICR#
; 6044 SC(
;
;This routine has multiple RPCs created to support the mobile Scheduling apps
;Line Tag ADMITS commented out due to the descoping the functionality in the first release
;ADMITS(RESULTS,DFN) ;Returns all admisssions for a patient MBAA RPC: MBAA PATIENT ADMISSIONS
;Input parameter: Patient DFN
;Returns:
; if admissions are found returns an array in the format of:
; 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
; if no admissions are found for the patient in the last year
; Returns:
; RESULTS(INC)="0^No admissions"
; Returns the following errors:
; RESULTS(0)="0^DFN Missing"
; RESULTS(0)="0^Not a patient at this facility"
;
;K MOVEDT,DTFLG
;I $G(DFN)'>0 S RESULTS(0)="0^DFN Missing" Q
;I '$D(^DPT($G(DFN),0)) S RESULTS(0)="0^Not a patient at this facility" Q
;I '$D(^DGPM("APTT1",DFN)) S RESULTS(0)="0^Patient has not been admitted at this facility" Q ;ICR#: 565 DGPM("APTT1"
;D NOW^%DTC S MOVEDT=$$FMADD^XLFDT(%,-366,0,0,0),INC=1,DTFLG=0 ; removed customer wants all admissions
;S MOVEDT="",INC=1,DTFLG=0
;I $D(^DGPM("APTT1",DFN)) D CHKDT
;I DTFLG=1 S RESULTS(0)="0^Patient has not been admitted at this facility in the last year." Q
;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
;.;K NODE,W1,WARD,RM1,RMBED,P1,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN,ADMITS
;.;S NODE=$G(^DGPM(REC,0)),ADFLG=0
;.;S ADFLG=0
;.;D GETS^DIQ(405,REC,".04;.06;.07;.08;.09;.1;.17;.19","IE","ADMITS")
;.;S W1=$P(NODE,"^",6) S:$G(W1)>0 WARD=$P(^DIC(42,W1,0),"^") ;ICR#: 10039
;.;S WARD=$G(ADMITS(405,REC_",",.06,"E"))
;.;S RM1=$P(NODE,"^",7) S:$G(RM1)>0 RMBED=$P(^DG(405.4,RM1,0),"^") ;ICR#: 1380 DG(405.4
;.;S RMBED=$G(ADMITS(405,REC_",",.07,"E"))
;.;S (DGPP,DGAP)="" D NOW^%DTC S NOWI=9999999.999999-% K %
;.;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(
;.;S S1=$P(NODE,"^",9) S:$G(S1)>0 TRSPCLTY=$P(^DIC(45.7,S1,0),"^") ;ICR#: 362
;.;S TRSPCLTY=$G(ADMITS(405,REC_",",.09,"E"))
;.;S SHRTDIAG=$P(NODE,"^",10)
;.;S SHRTDIAG=$G(ADMITS(405,REC_",",.1,"E"))
;.;S DISFLAG=$P(NODE,"^",17)
;.;S DISFLAG=$G(ADMITS(405,REC_",",.17,"I"))
;.;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
;.;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
;.;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
;.;K NODE,W1,WARD,RM1,RMBED,P1,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN
;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
;Q
;T13 Change to remove the linetag TS1 as it is not used in the first release of SCV
;TS1 ;
;N ADMITS1
;D GETS^DIQ(405,IFN,".08;.19","IE","ADMITS1")
;S PROVIDER=$G(ADMITS1(405,IFN_",",.08,"E")),ATENDING=$G(ADMITS1(405,IFN_",",.19,"E"))
;K PROVIDER,ATENDING
;Q
GETPROV(PROV1,CLINID) ; Get a list of providers by clinic - RPC MBAA PROVIDERS BY CLINIC
; RPC MBAA PROVIDERS BY CLINIC
; INPUT PARAMETER: CLINIC ID - IEN for the clinic in the HOSPITAL LOCATION File (#44)
; OUTPUT: Array of providers in the format
; Success: ARRAY(I)=DFN^PROVIDER NAME
; Failure: ARRAY(0)="0^ERROR CODE"
;
N ERR,CLINIC
I $G(CLINID)="" S PROV1(1)="0^CLINIC ID IS NULL" Q
S CLINIC=$$GET1^DIQ(44,CLINID,.01) I $G(CLINIC)="" S PROV1(1)="0^CLINIC DOESN'T EXIST" Q ;ICR#: 6044 SC(
D GETS^DIQ(44,$G(CLINID),"2600*","IE","PROV")
S CNT=1,XX="" F S XX=$O(PROV(44.1,XX)) Q:XX="" D
.K PIEN,PNAME
.S PIEN=$G(PROV(44.1,XX,.01,"I")),PNAME=$G(PROV(44.1,XX,.01,"E"))
.I $G(PIEN)>0 S PROV1(CNT)=$G(PIEN)_"^"_$G(PNAME),CNT=CNT+1
.K PIEN,PNAME
K CNT,CLINID,CLINIC,XX,PROV,PIEN,PNAME
I $G(PROV1(1))="" S PROV1(1)="NO PROVIDERS ASSIGNED TO THE CLINIC"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAARPC3 4786 printed Apr 09, 2024@21:16:51 Page 2
MBAARPC3 ;OIT-PD/PB - Scheduling RPCs ;02/10/2016
+1 ;;1.0;Scheduling Calendar View;**1**;Feb 13, 2015;Build 85
+2 ;
+3 ;Associated ICRs:
+4 ; ICR#
+5 ; 6044 SC(
+6 ;
+7 ;This routine has multiple RPCs created to support the mobile Scheduling apps
+8 ;Line Tag ADMITS commented out due to the descoping the functionality in the first release
+9 ;ADMITS(RESULTS,DFN) ;Returns all admisssions for a patient MBAA RPC: MBAA PATIENT ADMISSIONS
+10 ;Input parameter: Patient DFN
+11 ;Returns:
+12 ; if admissions are found returns an array in the format of:
+13 ; 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
+14 ; if no admissions are found for the patient in the last year
+15 ; Returns:
+16 ; RESULTS(INC)="0^No admissions"
+17 ; Returns the following errors:
+18 ; RESULTS(0)="0^DFN Missing"
+19 ; RESULTS(0)="0^Not a patient at this facility"
+20 ;
+21 ;K MOVEDT,DTFLG
+22 ;I $G(DFN)'>0 S RESULTS(0)="0^DFN Missing" Q
+23 ;I '$D(^DPT($G(DFN),0)) S RESULTS(0)="0^Not a patient at this facility" Q
+24 ;I '$D(^DGPM("APTT1",DFN)) S RESULTS(0)="0^Patient has not been admitted at this facility" Q ;ICR#: 565 DGPM("APTT1"
+25 ;D NOW^%DTC S MOVEDT=$$FMADD^XLFDT(%,-366,0,0,0),INC=1,DTFLG=0 ; removed customer wants all admissions
+26 ;S MOVEDT="",INC=1,DTFLG=0
+27 ;I $D(^DGPM("APTT1",DFN)) D CHKDT
+28 ;I DTFLG=1 S RESULTS(0)="0^Patient has not been admitted at this facility in the last year." Q
+29 ;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
+30 ;.;K NODE,W1,WARD,RM1,RMBED,P1,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN,ADMITS
+31 ;.;S NODE=$G(^DGPM(REC,0)),ADFLG=0
+32 ;.;S ADFLG=0
+33 ;.;D GETS^DIQ(405,REC,".04;.06;.07;.08;.09;.1;.17;.19","IE","ADMITS")
+34 ;.;S W1=$P(NODE,"^",6) S:$G(W1)>0 WARD=$P(^DIC(42,W1,0),"^") ;ICR#: 10039
+35 ;.;S WARD=$G(ADMITS(405,REC_",",.06,"E"))
+36 ;.;S RM1=$P(NODE,"^",7) S:$G(RM1)>0 RMBED=$P(^DG(405.4,RM1,0),"^") ;ICR#: 1380 DG(405.4
+37 ;.;S RMBED=$G(ADMITS(405,REC_",",.07,"E"))
+38 ;.;S (DGPP,DGAP)="" D NOW^%DTC S NOWI=9999999.999999-% K %
+39 ;.;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(
+40 ;.;S S1=$P(NODE,"^",9) S:$G(S1)>0 TRSPCLTY=$P(^DIC(45.7,S1,0),"^") ;ICR#: 362
+41 ;.;S TRSPCLTY=$G(ADMITS(405,REC_",",.09,"E"))
+42 ;.;S SHRTDIAG=$P(NODE,"^",10)
+43 ;.;S SHRTDIAG=$G(ADMITS(405,REC_",",.1,"E"))
+44 ;.;S DISFLAG=$P(NODE,"^",17)
+45 ;.;S DISFLAG=$G(ADMITS(405,REC_",",.17,"I"))
+46 ;.;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
+47 ;.;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
+48 ;.;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
+49 ;.;K NODE,W1,WARD,RM1,RMBED,P1,PROVIDER,ATENDING,DGPP,DGAP,S1,TRSPCLTY,SHRTDIAG,DISFLAG,ADFLG,DISDATE,R1,TYPEDIS,STAYLEN
+50 ;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
+51 ;Q
+52 ;T13 Change to remove the linetag TS1 as it is not used in the first release of SCV
+53 ;TS1 ;
+54 ;N ADMITS1
+55 ;D GETS^DIQ(405,IFN,".08;.19","IE","ADMITS1")
+56 ;S PROVIDER=$G(ADMITS1(405,IFN_",",.08,"E")),ATENDING=$G(ADMITS1(405,IFN_",",.19,"E"))
+57 ;K PROVIDER,ATENDING
+58 ;Q
GETPROV(PROV1,CLINID) ; Get a list of providers by clinic - RPC MBAA PROVIDERS BY CLINIC
+1 ; RPC MBAA PROVIDERS BY CLINIC
+2 ; INPUT PARAMETER: CLINIC ID - IEN for the clinic in the HOSPITAL LOCATION File (#44)
+3 ; OUTPUT: Array of providers in the format
+4 ; Success: ARRAY(I)=DFN^PROVIDER NAME
+5 ; Failure: ARRAY(0)="0^ERROR CODE"
+6 ;
+7 NEW ERR,CLINIC
+8 IF $GET(CLINID)=""
SET PROV1(1)="0^CLINIC ID IS NULL"
QUIT
+9 ;ICR#: 6044 SC(
SET CLINIC=$$GET1^DIQ(44,CLINID,.01)
IF $GET(CLINIC)=""
SET PROV1(1)="0^CLINIC DOESN'T EXIST"
QUIT
+10 DO GETS^DIQ(44,$GET(CLINID),"2600*","IE","PROV")
+11 SET CNT=1
SET XX=""
FOR
SET XX=$ORDER(PROV(44.1,XX))
if XX=""
QUIT
Begin DoDot:1
+12 KILL PIEN,PNAME
+13 SET PIEN=$GET(PROV(44.1,XX,.01,"I"))
SET PNAME=$GET(PROV(44.1,XX,.01,"E"))
+14 IF $GET(PIEN)>0
SET PROV1(CNT)=$GET(PIEN)_"^"_$GET(PNAME)
SET CNT=CNT+1
+15 KILL PIEN,PNAME
End DoDot:1
+16 KILL CNT,CLINID,CLINIC,XX,PROV,PIEN,PNAME
+17 IF $GET(PROV1(1))=""
SET PROV1(1)="NO PROVIDERS ASSIGNED TO THE CLINIC"
+18 QUIT
