PSGOEF2 ;BIR/JMC - INPATIENT MEDS OVERLAPPING ADMIN TIMES ;23 Jun 09 / 2:48 PM
;;5.0;INPATIENT MEDICATIONS ;**222,264**;16 DEC 97;Build 3
;
; Reference to ORCD is supported by DBIA 5493.
;
Q
;
OVERLAP ; Check for overlapping admin times on complex orders with "AND" conjunction.
K ORDIALOG,^TMP("PSJATOVR",$J) ;Have to use array name ORDIALOG even though it's not PSJ namespaced.
S PSJOVRLP=0
N PSJORDLG,X,CNT,TOTCONJ
S PSJORDLG=$$PTR^ORCD("PSJ OR PAT OE") I PSJORDLG="" Q ;locates dialog sequence for Inpatient Meds dialog in CPRS.
D GETDLG^ORCD(PSJORDLG) ;retrieves info about Inpatient Meds dialog setup in CPRS
S X="" F S X=$O(ORDIALOG(X)) Q:X="" D
. I $P($G(ORDIALOG(X)),"^",2)="CONJ" D GETDLG1^ORCD(PSJORDLG),GETORDER^ORCD(PSJCOM) M PSJOVR("CONJ")=ORDIALOG(X)
. I $P($G(ORDIALOG(X)),"^",2)="ADMIN" D GETDLG1^ORCD(PSJORDLG),GETORDER^ORCD(PSJCOM) M PSJOVR("ADMIN")=ORDIALOG(X)
. I $P($G(ORDIALOG(X)),"^",2)="SCHEDULE" D GETDLG1^ORCD(PSJORDLG),GETORDER^ORCD(PSJCOM) M PSJOVR("SCHEDULE")=ORDIALOG(X)
K ORDIALOG
; Clean up array below by killing unnecessary nodes
F X="CONJ","ADMIN","SCHEDULE" K PSJOVR(X,0),PSJOVR(X,"A"),PSJOVR(X,"?"),PSJOVR(X,"??") I X="ADMIN" M PSJOVR(X_"O")=PSJOVR(X)
; Look for no AND conjunctions. If no AND conjuncitons, quit.
S X="",CNT=0,TOTCONJ=$O(PSJOVR("CONJ",""),-1)
F S X=$O(PSJOVR("CONJ",X)) Q:X="" I PSJOVR("CONJ",X)="A" S CNT=CNT+1
Q:CNT=0 ;if CNT=0, there are no AND conjunctions in the order. No need to proceed further.
D BUILD
; Format all admin times to 4 digit length for comparison.
S X="" F S X=$O(PSJOVR("ADMIN",X)) Q:X="" D
. S X1=$G(PSJOVR("ADMIN",X)),X2=$L(X1,"-")
. F X3=1:1:X2 D
. . I $L($P(X1,"-",X3))<4 S $P(X1,"-",X3)=$P(X1,"-",X3)_"00"
. . S PSJOVR("ADMIN",X)=X1,PSJADOV(X,$P(X1,"-",X3))=""
; Order contains all AND conjunctions, no THEN conjunctions.
I CNT=TOTCONJ D CHK,EXIT Q
; Piece order back together in a string of part number, conjunction
; Produces a string like 1A2T3 - part 1 AND part 2 THEN part 3
S X="" F S X=$O(PSJOVR("ADMIN",X)) Q:X="" D
. S PSJOVR("STRING")=$G(PSJOVR("STRING"))_X_$G(PSJOVR("CONJ",X))
. S PSJTHEN=$L(PSJOVR("STRING"),"T")
. S PSJTHEN1="" F PSJTHEN1=1:1:PSJTHEN D
. . I $P(PSJOVR("STRING"),"T",PSJTHEN1)'["A" Q ;No need to check for overlap if only one part to a THEN conjunction
. . S PSJAND=$L($P(PSJOVR("STRING"),"T",PSJTHEN1),"A")
. . S PSJAND1="" F PSJAND1=1:1:PSJAND D
. . . S PSJAND(PSJTHEN1,PSJAND1)=$P($P(PSJOVR("STRING"),"T",PSJTHEN1),"A",PSJAND1)
D CHK2,EXIT
Q
CHK ;
Q:'CNT
K PSJADOVR
S X=""
F X=1:1:CNT D
. S X2="" F S X2=$O(PSJADOV(X2)) Q:X2="" D
. . ;*PSJ*5*264
. . N DAYOVLP,DWSCH
. . I ("SU-MO-TU-WE-TH-FR-SA"[$P($P(PSJOVR("SCHEDULE",X2),"@"),"-")),$D(PSJOVR("SCHEDULE",X2+X)),("SU-MO-TU-WE-TH-FR-SA"[$P($P(PSJOVR("SCHEDULE",X2+X),"@"),"-")) S DWSCH=1 D DWCHK(PSJOVR("SCHEDULE",X2),PSJOVR("SCHEDULE",X2+X))
. . S X3="" F S X3=$O(PSJADOV(X2,X3)) Q:X3="" D
. . . I $D(PSJADOV(X2+X,X3)),$S($G(DWSCH):$G(DAYOVLP),1:1) S $P(^TMP("PSJATOVR",$J,X2),"^",4)=1,$P(^TMP("PSJATOVR",$J,X2+X),"^",4)=1,PSJOVRLP=1
Q
;
DWCHK(X,Y) ; PSJ*5*264 - DWCHK added
N SCH1,SCH2,DAY S SCH1=$P(X,"@",1),SCH2=$P(Y,"@",1)
F CNT=1:1:$L(SCH1,"-") Q:$G(DAYOVLP) D
. S DAY=$P(SCH1,"-",CNT)
. I SCH2[DAY S DAYOVLP=1 Q
Q
;
CHK2 ;
Q:'$G(PSJAND1)
S (X,X1,X2,X3,X4,PSJZT)=""
K PSJADOVR
F X=1:1:PSJAND1 D
. S X2="" F S X2=$O(PSJAND(X2)) Q:X2="" D
. . S X3="" F S X3=$O(PSJAND(X2,X3)) Q:X3="" D
. . . S X4=$G(PSJAND(X2,X3))
. . . Q:X4=""
. . . M PSJADOVR(X2,X3,X4)=PSJADOV(X4)
F PSJZT=1:1:PSJAND1 D
. S X="" F S X=$O(PSJADOVR(X)) Q:X="" D
. . S X1="" F S X1=$O(PSJADOVR(X,X1)) Q:X1="" D
. . . S X2="" F S X2=$O(PSJADOVR(X,X1,X2)) Q:X2="" D
. . . . S X3="" F S X3=$O(PSJADOVR(X,X1,X2,X3)) Q:X3="" D
. . . . . I $D(PSJADOVR(X,X1+PSJZT,X2+PSJZT,X3)) S $P(^TMP("PSJATOVR",$J,X2),"^",4)=1,$P(^TMP("PSJATOVR",$J,X2+PSJZT),"^",4)=1,PSJOVRLP=1
Q
;
BUILD ;
S X="" F S X=$O(PSJOVR("SCHEDULE",X)) Q:X="" S ^TMP("PSJATOVR",$J,X)=X_"^"_$G(PSJOVR("SCHEDULE",X))
S X="" F S X=$O(PSJOVR("ADMIN",X)) Q:X="" S ^TMP("PSJATOVR",$J,X)=^TMP("PSJATOVR",$J,X)_"^"_$G(PSJOVR("ADMIN",X))_"^0"
Q
;
EXIT ; Kill variables
K PSJAND,PSJAND1,PSJTHEN,PSJTHEN1,PSJADOVR,PSJADOV,PSJADOV2
K X,X1,X2,X3,X4,PSJZT,TOTCONJ,CNT,PSJORDLG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOEF2 4377 printed Nov 22, 2024@17:12:17 Page 2
PSGOEF2 ;BIR/JMC - INPATIENT MEDS OVERLAPPING ADMIN TIMES ;23 Jun 09 / 2:48 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**222,264**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ORCD is supported by DBIA 5493.
+4 ;
+5 QUIT
+6 ;
OVERLAP ; Check for overlapping admin times on complex orders with "AND" conjunction.
+1 ;Have to use array name ORDIALOG even though it's not PSJ namespaced.
KILL ORDIALOG,^TMP("PSJATOVR",$JOB)
+2 SET PSJOVRLP=0
+3 NEW PSJORDLG,X,CNT,TOTCONJ
+4 ;locates dialog sequence for Inpatient Meds dialog in CPRS.
SET PSJORDLG=$$PTR^ORCD("PSJ OR PAT OE")
IF PSJORDLG=""
QUIT
+5 ;retrieves info about Inpatient Meds dialog setup in CPRS
DO GETDLG^ORCD(PSJORDLG)
+6 SET X=""
FOR
SET X=$ORDER(ORDIALOG(X))
if X=""
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(ORDIALOG(X)),"^",2)="CONJ"
DO GETDLG1^ORCD(PSJORDLG)
DO GETORDER^ORCD(PSJCOM)
MERGE PSJOVR("CONJ")=ORDIALOG(X)
+8 IF $PIECE($GET(ORDIALOG(X)),"^",2)="ADMIN"
DO GETDLG1^ORCD(PSJORDLG)
DO GETORDER^ORCD(PSJCOM)
MERGE PSJOVR("ADMIN")=ORDIALOG(X)
+9 IF $PIECE($GET(ORDIALOG(X)),"^",2)="SCHEDULE"
DO GETDLG1^ORCD(PSJORDLG)
DO GETORDER^ORCD(PSJCOM)
MERGE PSJOVR("SCHEDULE")=ORDIALOG(X)
End DoDot:1
+10 KILL ORDIALOG
+11 ; Clean up array below by killing unnecessary nodes
+12 FOR X="CONJ","ADMIN","SCHEDULE"
KILL PSJOVR(X,0),PSJOVR(X,"A"),PSJOVR(X,"?"),PSJOVR(X,"??")
IF X="ADMIN"
MERGE PSJOVR(X_"O")=PSJOVR(X)
+13 ; Look for no AND conjunctions. If no AND conjuncitons, quit.
+14 SET X=""
SET CNT=0
SET TOTCONJ=$ORDER(PSJOVR("CONJ",""),-1)
+15 FOR
SET X=$ORDER(PSJOVR("CONJ",X))
if X=""
QUIT
IF PSJOVR("CONJ",X)="A"
SET CNT=CNT+1
+16 ;if CNT=0, there are no AND conjunctions in the order. No need to proceed further.
if CNT=0
QUIT
+17 DO BUILD
+18 ; Format all admin times to 4 digit length for comparison.
+19 SET X=""
FOR
SET X=$ORDER(PSJOVR("ADMIN",X))
if X=""
QUIT
Begin DoDot:1
+20 SET X1=$GET(PSJOVR("ADMIN",X))
SET X2=$LENGTH(X1,"-")
+21 FOR X3=1:1:X2
Begin DoDot:2
+22 IF $LENGTH($PIECE(X1,"-",X3))<4
SET $PIECE(X1,"-",X3)=$PIECE(X1,"-",X3)_"00"
+23 SET PSJOVR("ADMIN",X)=X1
SET PSJADOV(X,$PIECE(X1,"-",X3))=""
End DoDot:2
End DoDot:1
+24 ; Order contains all AND conjunctions, no THEN conjunctions.
+25 IF CNT=TOTCONJ
DO CHK
DO EXIT
QUIT
+26 ; Piece order back together in a string of part number, conjunction
+27 ; Produces a string like 1A2T3 - part 1 AND part 2 THEN part 3
+28 SET X=""
FOR
SET X=$ORDER(PSJOVR("ADMIN",X))
if X=""
QUIT
Begin DoDot:1
+29 SET PSJOVR("STRING")=$GET(PSJOVR("STRING"))_X_$GET(PSJOVR("CONJ",X))
+30 SET PSJTHEN=$LENGTH(PSJOVR("STRING"),"T")
+31 SET PSJTHEN1=""
FOR PSJTHEN1=1:1:PSJTHEN
Begin DoDot:2
+32 ;No need to check for overlap if only one part to a THEN conjunction
IF $PIECE(PSJOVR("STRING"),"T",PSJTHEN1)'["A"
QUIT
+33 SET PSJAND=$LENGTH($PIECE(PSJOVR("STRING"),"T",PSJTHEN1),"A")
+34 SET PSJAND1=""
FOR PSJAND1=1:1:PSJAND
Begin DoDot:3
+35 SET PSJAND(PSJTHEN1,PSJAND1)=$PIECE($PIECE(PSJOVR("STRING"),"T",PSJTHEN1),"A",PSJAND1)
End DoDot:3
End DoDot:2
End DoDot:1
+36 DO CHK2
DO EXIT
+37 QUIT
CHK ;
+1 if 'CNT
QUIT
+2 KILL PSJADOVR
+3 SET X=""
+4 FOR X=1:1:CNT
Begin DoDot:1
+5 SET X2=""
FOR
SET X2=$ORDER(PSJADOV(X2))
if X2=""
QUIT
Begin DoDot:2
+6 ;*PSJ*5*264
+7 NEW DAYOVLP,DWSCH
+8 IF ("SU-MO-TU-WE-TH-FR-SA"[$PIECE($PIECE(PSJOVR("SCHEDULE",X2),"@"),"-"))
IF $DATA(PSJOVR("SCHEDULE",X2+X))
IF ("SU-MO-TU-WE-TH-FR-SA"[$PIECE($PIECE(PSJOVR("SCHEDULE",X2+X),"@"),"-"))
SET DWSCH=1
DO DWCHK(PSJOVR("SCHEDULE",X2),PSJOVR("SCHEDULE",X2+X))
+9 SET X3=""
FOR
SET X3=$ORDER(PSJADOV(X2,X3))
if X3=""
QUIT
Begin DoDot:3
+10 IF $DATA(PSJADOV(X2+X,X3))
IF $SELECT($GET(DWSCH):$GET(DAYOVLP),1:1)
SET $PIECE(^TMP("PSJATOVR",$JOB,X2),"^",4)=1
SET $PIECE(^TMP("PSJATOVR",$JOB,X2+X),"^",4)=1
SET PSJOVRLP=1
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
DWCHK(X,Y) ; PSJ*5*264 - DWCHK added
+1 NEW SCH1,SCH2,DAY
SET SCH1=$PIECE(X,"@",1)
SET SCH2=$PIECE(Y,"@",1)
+2 FOR CNT=1:1:$LENGTH(SCH1,"-")
if $GET(DAYOVLP)
QUIT
Begin DoDot:1
+3 SET DAY=$PIECE(SCH1,"-",CNT)
+4 IF SCH2[DAY
SET DAYOVLP=1
QUIT
End DoDot:1
+5 QUIT
+6 ;
CHK2 ;
+1 if '$GET(PSJAND1)
QUIT
+2 SET (X,X1,X2,X3,X4,PSJZT)=""
+3 KILL PSJADOVR
+4 FOR X=1:1:PSJAND1
Begin DoDot:1
+5 SET X2=""
FOR
SET X2=$ORDER(PSJAND(X2))
if X2=""
QUIT
Begin DoDot:2
+6 SET X3=""
FOR
SET X3=$ORDER(PSJAND(X2,X3))
if X3=""
QUIT
Begin DoDot:3
+7 SET X4=$GET(PSJAND(X2,X3))
+8 if X4=""
QUIT
+9 MERGE PSJADOVR(X2,X3,X4)=PSJADOV(X4)
End DoDot:3
End DoDot:2
End DoDot:1
+10 FOR PSJZT=1:1:PSJAND1
Begin DoDot:1
+11 SET X=""
FOR
SET X=$ORDER(PSJADOVR(X))
if X=""
QUIT
Begin DoDot:2
+12 SET X1=""
FOR
SET X1=$ORDER(PSJADOVR(X,X1))
if X1=""
QUIT
Begin DoDot:3
+13 SET X2=""
FOR
SET X2=$ORDER(PSJADOVR(X,X1,X2))
if X2=""
QUIT
Begin DoDot:4
+14 SET X3=""
FOR
SET X3=$ORDER(PSJADOVR(X,X1,X2,X3))
if X3=""
QUIT
Begin DoDot:5
+15 IF $DATA(PSJADOVR(X,X1+PSJZT,X2+PSJZT,X3))
SET $PIECE(^TMP("PSJATOVR",$JOB,X2),"^",4)=1
SET $PIECE(^TMP("PSJATOVR",$JOB,X2+PSJZT),"^",4)=1
SET PSJOVRLP=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
BUILD ;
+1 SET X=""
FOR
SET X=$ORDER(PSJOVR("SCHEDULE",X))
if X=""
QUIT
SET ^TMP("PSJATOVR",$JOB,X)=X_"^"_$GET(PSJOVR("SCHEDULE",X))
+2 SET X=""
FOR
SET X=$ORDER(PSJOVR("ADMIN",X))
if X=""
QUIT
SET ^TMP("PSJATOVR",$JOB,X)=^TMP("PSJATOVR",$JOB,X)_"^"_$GET(PSJOVR("ADMIN",X))_"^0"
+3 QUIT
+4 ;
EXIT ; Kill variables
+1 KILL PSJAND,PSJAND1,PSJTHEN,PSJTHEN1,PSJADOVR,PSJADOV,PSJADOV2
+2 KILL X,X1,X2,X3,X4,PSJZT,TOTCONJ,CNT,PSJORDLG
+3 QUIT
