- 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
