ADEPQA1D ; IHS/HQT/MJL - CODE SCREENS ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;
CODSCN(ADEDFN) ;EP - Returns 1 if ADEDFN passes code screens in ADEADA(1)
Q:$P(ADEADA(1),U,2)="" 1 ;No code screens at all
N ADEK,ADEJ,ADEL,ADEFLG,ADEVFLG,ADECOD,ADEFOL,ADEOP,ADEPAT,ADEDAYS,ADESAM,ADEVDAT
S ADEPAT=$P(ADENOD,U)
S ADEVDAT=$P(ADENOD,U,2)
I $P(ADEADA(1),U,3)]"",'$D(ADEHXC) S ADEHXC=ADEPAT D ^ADEGRL33
I $P(ADEADA(1),U,3)]"",ADEHXC'=ADEPAT K ADEHXC,ADEHXO S ADEHXC=ADEPAT D ^ADEGRL33
S ADEFLG=0,ADEVFLG=0
S ADEDAYS=$P(ADEADA(1),U,5) I ADEDAYS]"" D
. S X1=ADEVDAT ;FM Date of current entry
. S X2=ADEDAYS
. S %DT="" D C^%DTC S ADEDAYS=X K X
S ADESAM=$P(ADEADA(1),U,6)
F ADEJ=1:1:$L($P(ADEADA(1),U,2),",") S ADECOD=$P($P(ADEADA(1),U,2),",",ADEJ) D
. F ADEK=1:1:$L($P(ADEADA(1),U,3),",") S ADEFOL=$P($P(ADEADA(1),U,3),",",ADEK) D
. . F ADEL=1:1:$L($P(ADEADA(1),U,7),",") S ADEOP=$P($P(ADEADA(1),U,7),",",ADEL) D
. . . S ADEFLG=$$CODSCN1(ADECOD,ADEFOL,ADEOP,ADEDAYS,ADESAM) S:ADEFLG ADEVFLG=1
Q ADEVFLG
K ADEDAYS,ADESAM,ADEVDAT,ADEVFLG ;*NE
;
CODSCN1(ADECOD,ADEFOL,ADEOP,ADEDAYS,ADESAM) ;Returns 1 if code assoc w opsite exists
N ADEFLG,ADEJ,ADENOD,ADEFLG2
S ADEFLG=0
I '$D(^ADEPCD(ADEDFN,"ADA","B",ADECOD)) Q 0
S ADEJ=0
F S ADEJ=$O(^ADEPCD(ADEDFN,"ADA","B",ADECOD,ADEJ)) Q:'ADEJ D
. S ADENOD=^ADEPCD(ADEDFN,"ADA",ADEJ,0)
. I $P(ADENOD,U,5)'="" Q
. I ADEOP]"",$P(ADENOD,U,2)'=ADEOP Q
. ;At this point, the primary code must exist, so test for followed-by
. I ADEFOL="" S ADEFLG=1 S ^ADEUTL("ADEPQA",$J,ADEDFN,ADEJ)="" Q
. ;Find out if this code hits on the followed by
. S ADEFLG2=$$CODSCN2(ADECOD,ADEFOL,ADESAM,ADEOP,ADEDAYS)
. ;If it does:
. ; and NOT then quit this Do (ADEFLG unchanged)
. I ADEFLG2,$P(ADEADA(1),U,4) Q
. ; and not NOT then set D0,D1 and ADEFLG=1 and quit this Do
. I ADEFLG2,'$P(ADEADA(1),U,4) S ADEFLG=1,^ADEUTL("ADEPQA",$J,ADEDFN,ADEJ)="" Q
. ;If it does not:
. ; and NOT then set D0,D1 and ADEFLG=1 and quit this Do
. I 'ADEFLG2,$P(ADEADA(1),U,4) S ADEFLG=1,^ADEUTL("ADEPQA",$J,ADEDFN,ADEJ)="" Q
. ; and not NOT then quit this Do (ADEFLG still 0)
. I 'ADEFLG2,'$P(ADEADA(1),U,4) Q
;
;I ADEFOL="" Q ADEFLG
;I $P(ADEADA(1),U,4) Q:ADEFLG 0 Q 1 ;If the NOT flag applies
Q ADEFLG
K ADEFLG2 ;*NE
;
CODSCN2(ADECOD,ADEFOL,ADESAM,ADEOP,ADEDAYS) ;
;Returns 1 if ADECOD is followed by ADEFOL within ADEDAYS
;If ADESAM, then both ADEFOL and ADECOD must apply to the same opsite
;If ADEOP is defined, both must apply to it
;Assumes ADEHXC and ADEHXO arrays (pt tx history) have been defined
;Have to convert ADECOD from DFN to ADA CODE since ADEHXn arrays
;ADEVDAT-.0001 Means will hit on codes on same visit. Need addtl
;parameter to know if should or shouldn't hit on same visit
N ADEOPC,ADEFLG,ADESAME
S ADESAME=ADEVDAT ;-.0001
I $P(ADEADA(1),U,8)]"" S ADESAME=ADESAME-.0001
S ADEFLG=0
S ADECOD=$P(^AUTTADA(ADECOD,0),U)
S ADEFOL=$P(^AUTTADA(ADEFOL,0),U)
I ADEOP="",ADESAM]"" D Q ADEFLG
. S ADEOPC=$P(ADENOD,U,2)
. I ADEOPC="" Q
. I '$D(ADEHXO(ADEOPC,ADEFOL)) Q
. I $O(ADEHXO(ADEOPC,ADEFOL,ADESAME))="" Q
. I $O(ADEHXO(ADEOPC,ADEFOL,ADESAME))<ADEDAYS S ADEFLG=1
I ADEOP="",ADESAM="" D Q ADEFLG
. I '$D(ADEHXC(ADEFOL)) Q
. I $O(ADEHXC(ADEFOL,ADESAME))="" Q
. I $O(ADEHXC(ADEFOL,ADESAME))<ADEDAYS S ADEFLG=1
I ADEOP]"",ADESAM]"" D Q ADEFLG
. I '$D(ADEHXO(ADEOP,ADEFOL)) Q
. I $O(ADEHXO(ADEOP,ADEFOL,ADESAME))="" Q
. I $O(ADEHXO(ADEOP,ADEFOL,ADESAME))<ADEDAYS S ADEFLG=1
I ADEOP]"",ADESAM="" D Q ADEFLG
. I '$D(ADEHXC(ADEFOL)) Q
. I $O(ADEHXC(ADEFOL,ADESAME))="" Q
. I $O(ADEHXC(ADEFOL,ADESAME))<ADEDAYS S ADEFLG=1
Q ADEFLG
K ADEFOL ;*NE
ADEPQA1D ; IHS/HQT/MJL - CODE SCREENS ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
CODSCN(ADEDFN) ;EP - Returns 1 if ADEDFN passes code screens in ADEADA(1)
+1 ;No code screens at all
IF $PIECE(ADEADA(1),U,2)=""
QUIT 1
+2 NEW ADEK,ADEJ,ADEL,ADEFLG,ADEVFLG,ADECOD,ADEFOL,ADEOP,ADEPAT,ADEDAYS,ADESAM,ADEVDAT
+3 SET ADEPAT=$PIECE(ADENOD,U)
+4 SET ADEVDAT=$PIECE(ADENOD,U,2)
+5 IF $PIECE(ADEADA(1),U,3)]""
IF '$DATA(ADEHXC)
SET ADEHXC=ADEPAT
DO ^ADEGRL33
+6 IF $PIECE(ADEADA(1),U,3)]""
IF ADEHXC'=ADEPAT
KILL ADEHXC,ADEHXO
SET ADEHXC=ADEPAT
DO ^ADEGRL33
+7 SET ADEFLG=0
SET ADEVFLG=0
+8 SET ADEDAYS=$PIECE(ADEADA(1),U,5)
IF ADEDAYS]""
Begin DoDot:1
+9 ;FM Date of current entry
SET X1=ADEVDAT
+10 SET X2=ADEDAYS
+11 SET %DT=""
DO C^%DTC
SET ADEDAYS=X
KILL X
End DoDot:1
+12 SET ADESAM=$PIECE(ADEADA(1),U,6)
+13 FOR ADEJ=1:1:$LENGTH($PIECE(ADEADA(1),U,2),",")
SET ADECOD=$PIECE($PIECE(ADEADA(1),U,2),",",ADEJ)
Begin DoDot:1
+14 FOR ADEK=1:1:$LENGTH($PIECE(ADEADA(1),U,3),",")
SET ADEFOL=$PIECE($PIECE(ADEADA(1),U,3),",",ADEK)
Begin DoDot:2
+15 FOR ADEL=1:1:$LENGTH($PIECE(ADEADA(1),U,7),",")
SET ADEOP=$PIECE($PIECE(ADEADA(1),U,7),",",ADEL)
Begin DoDot:3
+16 SET ADEFLG=$$CODSCN1(ADECOD,ADEFOL,ADEOP,ADEDAYS,ADESAM)
IF ADEFLG
SET ADEVFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT ADEVFLG
+18 ;*NE
KILL ADEDAYS,ADESAM,ADEVDAT,ADEVFLG
+19 ;
CODSCN1(ADECOD,ADEFOL,ADEOP,ADEDAYS,ADESAM) ;Returns 1 if code assoc w opsite exists
+1 NEW ADEFLG,ADEJ,ADENOD,ADEFLG2
+2 SET ADEFLG=0
+3 IF '$DATA(^ADEPCD(ADEDFN,"ADA","B",ADECOD))
QUIT 0
+4 SET ADEJ=0
+5 FOR
SET ADEJ=$ORDER(^ADEPCD(ADEDFN,"ADA","B",ADECOD,ADEJ))
IF 'ADEJ
QUIT
Begin DoDot:1
+6 SET ADENOD=^ADEPCD(ADEDFN,"ADA",ADEJ,0)
+7 IF $PIECE(ADENOD,U,5)'=""
QUIT
+8 IF ADEOP]""
IF $PIECE(ADENOD,U,2)'=ADEOP
QUIT
+9 ;At this point, the primary code must exist, so test for followed-by
+10 IF ADEFOL=""
SET ADEFLG=1
SET ^ADEUTL("ADEPQA",$JOB,ADEDFN,ADEJ)=""
QUIT
+11 ;Find out if this code hits on the followed by
+12 SET ADEFLG2=$$CODSCN2(ADECOD,ADEFOL,ADESAM,ADEOP,ADEDAYS)
+13 ;If it does:
+14 ; and NOT then quit this Do (ADEFLG unchanged)
+15 IF ADEFLG2
IF $PIECE(ADEADA(1),U,4)
QUIT
+16 ; and not NOT then set D0,D1 and ADEFLG=1 and quit this Do
+17 IF ADEFLG2
IF '$PIECE(ADEADA(1),U,4)
SET ADEFLG=1
SET ^ADEUTL("ADEPQA",$JOB,ADEDFN,ADEJ)=""
QUIT
+18 ;If it does not:
+19 ; and NOT then set D0,D1 and ADEFLG=1 and quit this Do
+20 IF 'ADEFLG2
IF $PIECE(ADEADA(1),U,4)
SET ADEFLG=1
SET ^ADEUTL("ADEPQA",$JOB,ADEDFN,ADEJ)=""
QUIT
+21 ; and not NOT then quit this Do (ADEFLG still 0)
+22 IF 'ADEFLG2
IF '$PIECE(ADEADA(1),U,4)
QUIT
End DoDot:1
+23 ;
+24 ;I ADEFOL="" Q ADEFLG
+25 ;I $P(ADEADA(1),U,4) Q:ADEFLG 0 Q 1 ;If the NOT flag applies
+26 QUIT ADEFLG
+27 ;*NE
KILL ADEFLG2
+28 ;
CODSCN2(ADECOD,ADEFOL,ADESAM,ADEOP,ADEDAYS) ;
+1 ;Returns 1 if ADECOD is followed by ADEFOL within ADEDAYS
+2 ;If ADESAM, then both ADEFOL and ADECOD must apply to the same opsite
+3 ;If ADEOP is defined, both must apply to it
+4 ;Assumes ADEHXC and ADEHXO arrays (pt tx history) have been defined
+5 ;Have to convert ADECOD from DFN to ADA CODE since ADEHXn arrays
+6 ;ADEVDAT-.0001 Means will hit on codes on same visit. Need addtl
+7 ;parameter to know if should or shouldn't hit on same visit
+8 NEW ADEOPC,ADEFLG,ADESAME
+9 ;-.0001
SET ADESAME=ADEVDAT
+10 IF $PIECE(ADEADA(1),U,8)]""
SET ADESAME=ADESAME-.0001
+11 SET ADEFLG=0
+12 SET ADECOD=$PIECE(^AUTTADA(ADECOD,0),U)
+13 SET ADEFOL=$PIECE(^AUTTADA(ADEFOL,0),U)
+14 IF ADEOP=""
IF ADESAM]""
Begin DoDot:1
+15 SET ADEOPC=$PIECE(ADENOD,U,2)
+16 IF ADEOPC=""
QUIT
+17 IF '$DATA(ADEHXO(ADEOPC,ADEFOL))
QUIT
+18 IF $ORDER(ADEHXO(ADEOPC,ADEFOL,ADESAME))=""
QUIT
+19 IF $ORDER(ADEHXO(ADEOPC,ADEFOL,ADESAME))<ADEDAYS
SET ADEFLG=1
End DoDot:1
QUIT ADEFLG
+20 IF ADEOP=""
IF ADESAM=""
Begin DoDot:1
+21 IF '$DATA(ADEHXC(ADEFOL))
QUIT
+22 IF $ORDER(ADEHXC(ADEFOL,ADESAME))=""
QUIT
+23 IF $ORDER(ADEHXC(ADEFOL,ADESAME))<ADEDAYS
SET ADEFLG=1
End DoDot:1
QUIT ADEFLG
+24 IF ADEOP]""
IF ADESAM]""
Begin DoDot:1
+25 IF '$DATA(ADEHXO(ADEOP,ADEFOL))
QUIT
+26 IF $ORDER(ADEHXO(ADEOP,ADEFOL,ADESAME))=""
QUIT
+27 IF $ORDER(ADEHXO(ADEOP,ADEFOL,ADESAME))<ADEDAYS
SET ADEFLG=1
End DoDot:1
QUIT ADEFLG
+28 IF ADEOP]""
IF ADESAM=""
Begin DoDot:1
+29 IF '$DATA(ADEHXC(ADEFOL))
QUIT
+30 IF $ORDER(ADEHXC(ADEFOL,ADESAME))=""
QUIT
+31 IF $ORDER(ADEHXC(ADEFOL,ADESAME))<ADEDAYS
SET ADEFLG=1
End DoDot:1
QUIT ADEFLG
+32 QUIT ADEFLG
+33 ;*NE
KILL ADEFOL
