ADEPQA1C.m

ADEPQA1C ; IHS/HQT/MJL - SCREENS ;  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;

DATSCN(ADENOD) ;EP

 ;

 N ADEBEG,ADEND,ADEDAT

 S ADEBEG=$P(ADEDATE,U,2)

 S ADEND=$P(ADEDATE,U,3)

 S ADEDAT=$P(ADENOD,U,2)

 I ADEDAT'<ADEBEG&(ADEDAT'>ADEND) Q 1

 Q 0

 ;

AGESCN(ADENOD) ;EP - Returns 1 if patient age in range set in ADEAGE

 ;Requires variable ADEAGE

 N ADELO,ADEHI,ADEYRS,%DT

 S ADELO=$P(ADEAGE,U,2)

 S ADEHI=$P(ADEAGE,U,3)

 S X1=$P(ADENOD,U,2)

 S X2=$P(ADENOD,U)

 Q:'$D(^DPT(X2,0)) 0

 S X2=$P(^DPT(X2,0),U,3)

 Q:X2="" 0

 S %DT="" D D^%DTC

 ;beginning Y2K fix

 ;S ADEYRS=X\364.25

 S ADEYRS=X\365.25  ;Y2000

 ;end Y2K fix block

 Q:ADEYRS<ADELO!(ADEYRS>ADEHI) 0

 Q 1

 K ADEYRS,ADELO,ADEHI ;*NE

 ;

LOCSCN(ADENOD) ;EP - Returns 1 if ADEDFN at one of the locations in ADELOC

 N ADEFLG,ADEFAC,ADEJ

 S ADEFLG=0

 S ADEFAC=$P(ADELOC,"^",2)

 Q:ADEFAC="" 0

 F ADEJ=1:1:$L(ADEFAC,",") I $P(ADEFAC,",",ADEJ)=$P(ADENOD,U,3) S ADEFLG=1 Q

 Q ADEFLG

 ;

PRVSCN(ADENOD) ;EP - Returns 1 if ADEDFN has one of the dentists in ADEPROV

 N ADEFLG,ADEPRV,ADEJ

 S ADEFLG=0

 S ADEPRV=$P(ADEPROV,"^",2)

 Q:ADEPRV="" 0

 F ADEJ=1:1:$L(ADEPRV,",") I $P(ADEPRV,",",ADEJ)=$P(ADENOD,U,4) S ADEFLG=1 Q

 Q ADEFLG

 ;

HYGSCN(ADENOD) ;EP Returns 1 if ADEDFN has one of the hygienists in ADEHYG

 N ADEFLG,ADEPRV,ADEJ

 S ADEFLG=0

 S ADEPRV=$P(ADEHYG,"^",2)

 Q:ADEPRV="" 0

 F ADEJ=1:1:$L(ADEPRV,",") I $P(ADEPRV,",",ADEJ)=$P(ADENOD,U,5) S ADEFLG=1 Q

 Q ADEFLG

 ;

ADEPQA1C  ; IHS/HQT/MJL - SCREENS ;  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;

DATSCN(ADENOD) ;EP

 +1       ;

 +2        NEW ADEBEG,ADEND,ADEDAT

 +3        SET ADEBEG=$PIECE(ADEDATE,U,2)

 +4        SET ADEND=$PIECE(ADEDATE,U,3)

 +5        SET ADEDAT=$PIECE(ADENOD,U,2)

 +6        IF ADEDAT'<ADEBEG&(ADEDAT'>ADEND)

               QUIT 1

 +7        QUIT 0

 +8       ;

AGESCN(ADENOD) ;EP - Returns 1 if patient age in range set in ADEAGE

 +1       ;Requires variable ADEAGE

 +2        NEW ADELO,ADEHI,ADEYRS,%DT

 +3        SET ADELO=$PIECE(ADEAGE,U,2)

 +4        SET ADEHI=$PIECE(ADEAGE,U,3)

 +5        SET X1=$PIECE(ADENOD,U,2)

 +6        SET X2=$PIECE(ADENOD,U)

 +7        IF '$DATA(^DPT(X2,0))

               QUIT 0

 +8        SET X2=$PIECE(^DPT(X2,0),U,3)

 +9        IF X2=""

               QUIT 0

 +10       SET %DT=""

           DO D^%DTC

 +11      ;beginning Y2K fix

 +12      ;S ADEYRS=X\364.25

 +13      ;Y2000

           SET ADEYRS=X\365.25

 +14      ;end Y2K fix block

 +15       IF ADEYRS<ADELO!(ADEYRS>ADEHI)

               QUIT 0

 +16       QUIT 1

 +17      ;*NE

           KILL ADEYRS,ADELO,ADEHI

 +18      ;

LOCSCN(ADENOD) ;EP - Returns 1 if ADEDFN at one of the locations in ADELOC

 +1        NEW ADEFLG,ADEFAC,ADEJ

 +2        SET ADEFLG=0

 +3        SET ADEFAC=$PIECE(ADELOC,"^",2)

 +4        IF ADEFAC=""

               QUIT 0

 +5        FOR ADEJ=1:1:$LENGTH(ADEFAC,",")

               IF $PIECE(ADEFAC,",",ADEJ)=$PIECE(ADENOD,U,3)

                   SET ADEFLG=1

                   QUIT 

 +6        QUIT ADEFLG

 +7       ;

PRVSCN(ADENOD) ;EP - Returns 1 if ADEDFN has one of the dentists in ADEPROV

 +1        NEW ADEFLG,ADEPRV,ADEJ

 +2        SET ADEFLG=0

 +3        SET ADEPRV=$PIECE(ADEPROV,"^",2)

 +4        IF ADEPRV=""

               QUIT 0

 +5        FOR ADEJ=1:1:$LENGTH(ADEPRV,",")

               IF $PIECE(ADEPRV,",",ADEJ)=$PIECE(ADENOD,U,4)

                   SET ADEFLG=1

                   QUIT 

 +6        QUIT ADEFLG

 +7       ;

HYGSCN(ADENOD) ;EP Returns 1 if ADEDFN has one of the hygienists in ADEHYG

 +1        NEW ADEFLG,ADEPRV,ADEJ

 +2        SET ADEFLG=0

 +3        SET ADEPRV=$PIECE(ADEHYG,"^",2)

 +4        IF ADEPRV=""

               QUIT 0

 +5        FOR ADEJ=1:1:$LENGTH(ADEPRV,",")

               IF $PIECE(ADEPRV,",",ADEJ)=$PIECE(ADENOD,U,5)

                   SET ADEFLG=1

                   QUIT 

 +6        QUIT ADEFLG

 +7       ;