PSSSCHED ;BIR/JMC-BUILD SCHEDULE LIST FOR CPRS GUI SELECTION ;Feb 12, 2021@13:11
;;1.0;PHARMACY DATA MANAGEMENT;**94,189,249**;9/30/97;Build 2
;
; Reference to SCHE^PSOSIG supported by DBIA 7227
;
Q ;Cannot be called directly. Must use API
;
SCHED(PSSWIEN,PSSARRY) ;Receive ward IEN from CPRS and return list of schedules.
;
;PSSWIEN = Ward IEN
;PSSARRY = array passed by reference from CPRS
;
;If there is a duplicate schedule, and if one of them contains
;ward-specific admin times for the ward location of the patient,
;the schedule returned for inclusion in the list of selectable
;schedules to CPRS will be the one with the ward-specific admin
;times. If neither duplicate has ward-specific admin times,
;then the current functionality of the schedule with the lowest
;IEN number will remain in place. If both (or more than one)
;duplicate schedules have ward-specific admin times for the ward
;location of the patient, then the one with the lowest IEN number
;will be the schedule returned to CPRS.
;
;Example: Patient's ward location is ICU
;^PS(51.1,"APPSJ","BID",1)=""
;^PS(51.1,"APPSJ","BID",2)=""
;
;If ^PS(51.1,1 does not have ward-specific admin times for
;the ICU, but ^PS(51.1,2 does, ^PS(51.1,2 will be in the list
;of schedules returned to CPRS.
;
;If neither schedule has ward-specific admin times for the ICU
;then ^PS(51.1,1 will be in the list of schedules returned to CPRS.
;
;If both schedules have ward-specific admin times for the ICU
;then ^PS(51.1,1 will be in the list of schedules returned to CPRS.
;
;The returned array to CPRS will be in the format:
;PSSARRY(n)=IEN^NAME^OUTPATIENT EXPANSION^SCHEDULE TYPE^ADMIN TIME
;
N PSSSKED,PSSSKED1,PSSSK
K ^TMP("PSSADMIN"),^TMP("PSSDUP")
I $G(PSSWIEN)="" S PSSWIEN=0
S PSSSKED=""
F S PSSSKED=$O(^PS(51.1,"APPSJ",PSSSKED)) Q:PSSSKED="" D
. S PSSSKED1="",PSSSK=1
. F S PSSSKED1=$O(^PS(51.1,"APPSJ",PSSSKED,PSSSKED1)) Q:PSSSKED1="" D
. . Q:$P($G(^PS(51.1,PSSSKED1,0)),"^",5)=""
. . Q:$$GET1^DIQ(51.1,PSSSKED1,12,"I") ;Schedule is marked Inactive
. . S ^TMP("PSSDUP",$J,PSSSKED,PSSSK)=PSSSKED1 ;Identify duplicate schedules to work with.
. . S ^TMP("PSSADMIN",$J,"STD",PSSSKED,PSSSKED1)=$S($P($G(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),"^",2)'="":$P($G(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),"^",2),1:$P($G(^PS(51.1,PSSSKED1,0)),"^",2))
. . S PSSSK=PSSSK+1
. I '$D(^TMP("PSSDUP",$J,PSSSKED,2)) K ^TMP("PSSDUP",$J,PSSSKED)
I $D(^TMP("PSSDUP")) D DUP,FORMAT,KILL Q ;Duplicate schedules - determine if any have ward-specific admin times
I '$D(^TMP("PSSDUP")) D FORMAT,KILL Q ;No duplicates in the schedule file - format for proper return to CPRS
Q
KILL ;
K ^TMP("PSSADMIN"),PSSSKED,PSSSKED1,PSSSK,PSSWIEN
Q
DUP ;Compare duplicates to see if any have ward-specific admin times.
S PSSSKED="",PSSSKED1=""
F S PSSSKED=$O(^TMP("PSSDUP",$J,PSSSKED)) Q:PSSSKED="" D
. S PSSSK=""
. F S PSSSK=$O(^TMP("PSSDUP",$J,PSSSKED,PSSSK)) Q:PSSSK="" D
. . S PSSSKED1=$G(^TMP("PSSDUP",$J,PSSSKED,PSSSK))
. . I '$D(^TMP("PSSADMIN",$J,"STD",PSSSKED)) S ^TMP("PSSADMIN",$J,"STD",PSSSKED,PSSSKED1)=$P($G(^PS(51.1,PSSSKED1,0)),"^",2)
. . I '$D(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),PSSSK>1 K ^TMP("PSSADMIN",$J,"STD",PSSSKED,PSSSKED1) Q
. . I $D(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),'$D(^TMP("PSSADMIN",$J,"WARD",PSSSKED)) S ^TMP("PSSADMIN",$J,"WARD",PSSSKED,PSSSKED1)=$P($G(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),"^",2)
. . I $D(^TMP("PSSADMIN",$J,"WARD",PSSSKED)) D Q
. . . K ^TMP("PSSADMIN",$J,"STD",PSSSKED)
. . . S ^TMP("PSSADMIN",$J,"STD",PSSSKED,PSSSKED1)=$G(^TMP("PSSADMIN",$J,"WARD",PSSSKED,PSSSKED1))
. . . K ^TMP("PSSADMIN",$J,"WARD",PSSSKED)
K ^TMP("PSSDUP")
Q
FORMAT ;Format array for proper return to CPRS
N PSSCNTR,PSSTMP,PSSEXP,PSSEXP1
S PSSSKED="",PSSSKED1="",PSSCNTR=1
F S PSSSKED=$O(^TMP("PSSADMIN",$J,"STD",PSSSKED)) Q:PSSSKED="" D
. F S PSSSKED1=$O(^TMP("PSSADMIN",$J,"STD",PSSSKED,PSSSKED1)) Q:PSSSKED1="" D
. . S PSSTMP=$G(^PS(51.1,PSSSKED1,0))
. . S PSSEXP=$P(PSSTMP,"^",8) I PSSEXP="",$T(SCHE^PSOSIG)]"" S PSSEXP1=$$SCHE^PSOSIG(PSSSKED) S:PSSEXP1'=PSSSKED PSSEXP=PSSEXP1
. . S PSSARRY(PSSCNTR)=PSSSKED1_"^"_PSSSKED_"^"_PSSEXP_"^"_$P(PSSTMP,"^",5)_"^"_$G(^TMP("PSSADMIN",$J,"STD",PSSSKED,PSSSKED1))
. . S PSSCNTR=PSSCNTR+1
K PSSCNTR,PSSTMP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSSCHED 4359 printed Oct 16, 2024@18:35:03 Page 2
PSSSCHED ;BIR/JMC-BUILD SCHEDULE LIST FOR CPRS GUI SELECTION ;Feb 12, 2021@13:11
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**94,189,249**;9/30/97;Build 2
+2 ;
+3 ; Reference to SCHE^PSOSIG supported by DBIA 7227
+4 ;
+5 ;Cannot be called directly. Must use API
QUIT
+6 ;
SCHED(PSSWIEN,PSSARRY) ;Receive ward IEN from CPRS and return list of schedules.
+1 ;
+2 ;PSSWIEN = Ward IEN
+3 ;PSSARRY = array passed by reference from CPRS
+4 ;
+5 ;If there is a duplicate schedule, and if one of them contains
+6 ;ward-specific admin times for the ward location of the patient,
+7 ;the schedule returned for inclusion in the list of selectable
+8 ;schedules to CPRS will be the one with the ward-specific admin
+9 ;times. If neither duplicate has ward-specific admin times,
+10 ;then the current functionality of the schedule with the lowest
+11 ;IEN number will remain in place. If both (or more than one)
+12 ;duplicate schedules have ward-specific admin times for the ward
+13 ;location of the patient, then the one with the lowest IEN number
+14 ;will be the schedule returned to CPRS.
+15 ;
+16 ;Example: Patient's ward location is ICU
+17 ;^PS(51.1,"APPSJ","BID",1)=""
+18 ;^PS(51.1,"APPSJ","BID",2)=""
+19 ;
+20 ;If ^PS(51.1,1 does not have ward-specific admin times for
+21 ;the ICU, but ^PS(51.1,2 does, ^PS(51.1,2 will be in the list
+22 ;of schedules returned to CPRS.
+23 ;
+24 ;If neither schedule has ward-specific admin times for the ICU
+25 ;then ^PS(51.1,1 will be in the list of schedules returned to CPRS.
+26 ;
+27 ;If both schedules have ward-specific admin times for the ICU
+28 ;then ^PS(51.1,1 will be in the list of schedules returned to CPRS.
+29 ;
+30 ;The returned array to CPRS will be in the format:
+31 ;PSSARRY(n)=IEN^NAME^OUTPATIENT EXPANSION^SCHEDULE TYPE^ADMIN TIME
+32 ;
+33 NEW PSSSKED,PSSSKED1,PSSSK
+34 KILL ^TMP("PSSADMIN"),^TMP("PSSDUP")
+35 IF $GET(PSSWIEN)=""
SET PSSWIEN=0
+36 SET PSSSKED=""
+37 FOR
SET PSSSKED=$ORDER(^PS(51.1,"APPSJ",PSSSKED))
if PSSSKED=""
QUIT
Begin DoDot:1
+38 SET PSSSKED1=""
SET PSSSK=1
+39 FOR
SET PSSSKED1=$ORDER(^PS(51.1,"APPSJ",PSSSKED,PSSSKED1))
if PSSSKED1=""
QUIT
Begin DoDot:2
+40 if $PIECE($GET(^PS(51.1,PSSSKED1,0)),"^",5)=""
QUIT
+41 ;Schedule is marked Inactive
if $$GET1^DIQ(51.1,PSSSKED1,12,"I")
QUIT
+42 ;Identify duplicate schedules to work with.
SET ^TMP("PSSDUP",$JOB,PSSSKED,PSSSK)=PSSSKED1
+43 SET ^TMP("PSSADMIN",$JOB,"STD",PSSSKED,PSSSKED1)=$SELECT($PIECE($GET(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),"^",2)'="":$PIECE($GET(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),"^",2),1:$PIECE($GET(^PS(51.1,PSSSKED1,0)),"^",2))
+44 SET PSSSK=PSSSK+1
End DoDot:2
+45 IF '$DATA(^TMP("PSSDUP",$JOB,PSSSKED,2))
KILL ^TMP("PSSDUP",$JOB,PSSSKED)
End DoDot:1
+46 ;Duplicate schedules - determine if any have ward-specific admin times
IF $DATA(^TMP("PSSDUP"))
DO DUP
DO FORMAT
DO KILL
QUIT
+47 ;No duplicates in the schedule file - format for proper return to CPRS
IF '$DATA(^TMP("PSSDUP"))
DO FORMAT
DO KILL
QUIT
+48 QUIT
KILL ;
+1 KILL ^TMP("PSSADMIN"),PSSSKED,PSSSKED1,PSSSK,PSSWIEN
+2 QUIT
DUP ;Compare duplicates to see if any have ward-specific admin times.
+1 SET PSSSKED=""
SET PSSSKED1=""
+2 FOR
SET PSSSKED=$ORDER(^TMP("PSSDUP",$JOB,PSSSKED))
if PSSSKED=""
QUIT
Begin DoDot:1
+3 SET PSSSK=""
+4 FOR
SET PSSSK=$ORDER(^TMP("PSSDUP",$JOB,PSSSKED,PSSSK))
if PSSSK=""
QUIT
Begin DoDot:2
+5 SET PSSSKED1=$GET(^TMP("PSSDUP",$JOB,PSSSKED,PSSSK))
+6 IF '$DATA(^TMP("PSSADMIN",$JOB,"STD",PSSSKED))
SET ^TMP("PSSADMIN",$JOB,"STD",PSSSKED,PSSSKED1)=$PIECE($GET(^PS(51.1,PSSSKED1,0)),"^",2)
+7 IF '$DATA(^PS(51.1,PSSSKED1,1,PSSWIEN,0))
IF PSSSK>1
KILL ^TMP("PSSADMIN",$JOB,"STD",PSSSKED,PSSSKED1)
QUIT
+8 IF $DATA(^PS(51.1,PSSSKED1,1,PSSWIEN,0))
IF '$DATA(^TMP("PSSADMIN",$JOB,"WARD",PSSSKED))
SET ^TMP("PSSADMIN",$JOB,"WARD",PSSSKED,PSSSKED1)=$PIECE($GET(^PS(51.1,PSSSKED1,1,PSSWIEN,0)),"^",2)
+9 IF $DATA(^TMP("PSSADMIN",$JOB,"WARD",PSSSKED))
Begin DoDot:3
+10 KILL ^TMP("PSSADMIN",$JOB,"STD",PSSSKED)
+11 SET ^TMP("PSSADMIN",$JOB,"STD",PSSSKED,PSSSKED1)=$GET(^TMP("PSSADMIN",$JOB,"WARD",PSSSKED,PSSSKED1))
+12 KILL ^TMP("PSSADMIN",$JOB,"WARD",PSSSKED)
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+13 KILL ^TMP("PSSDUP")
+14 QUIT
FORMAT ;Format array for proper return to CPRS
+1 NEW PSSCNTR,PSSTMP,PSSEXP,PSSEXP1
+2 SET PSSSKED=""
SET PSSSKED1=""
SET PSSCNTR=1
+3 FOR
SET PSSSKED=$ORDER(^TMP("PSSADMIN",$JOB,"STD",PSSSKED))
if PSSSKED=""
QUIT
Begin DoDot:1
+4 FOR
SET PSSSKED1=$ORDER(^TMP("PSSADMIN",$JOB,"STD",PSSSKED,PSSSKED1))
if PSSSKED1=""
QUIT
Begin DoDot:2
+5 SET PSSTMP=$GET(^PS(51.1,PSSSKED1,0))
+6 SET PSSEXP=$PIECE(PSSTMP,"^",8)
IF PSSEXP=""
IF $TEXT(SCHE^PSOSIG)]""
SET PSSEXP1=$$SCHE^PSOSIG(PSSSKED)
if PSSEXP1'=PSSSKED
SET PSSEXP=PSSEXP1
+7 SET PSSARRY(PSSCNTR)=PSSSKED1_"^"_PSSSKED_"^"_PSSEXP_"^"_$PIECE(PSSTMP,"^",5)_"^"_$GET(^TMP("PSSADMIN",$JOB,"STD",PSSSKED,PSSSKED1))
+8 SET PSSCNTR=PSSCNTR+1
End DoDot:2
End DoDot:1
+9 KILL PSSCNTR,PSSTMP
