PSGOEF2 ;BIR/JMC - INPATIENT MEDS OVERLAPPING ADMIN TIMES ;23 Jun 09 / 2:48 PM
;;5.0; INPATIENT MEDICATIONS ;**222**;16 DEC 97;Build 5
;
; 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
. . S X3="" F S X3=$O(PSJADOV(X2,X3)) Q:X3="" D
. . . I $D(PSJADOV(X2+X,X3)) S $P(^TMP("PSJATOVR",$J,X2),"^",4)=1,$P(^TMP("PSJATOVR",$J,X2+X),"^",4)=1,PSJOVRLP=1
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
PSGOEF2 ;BIR/JMC - INPATIENT MEDS OVERLAPPING ADMIN TIMES ;23 Jun 09 / 2:48 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**222**;16 DEC 97;Build 5
+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 SET X3=""
FOR
SET X3=$ORDER(PSJADOV(X2,X3))
IF X3=""
QUIT
Begin DoDot:3
+7 IF $DATA(PSJADOV(X2+X,X3))
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
+8 QUIT
+9 ;
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
