APCDKDE1.m

APCDKDE1 ; IHS/CMI/LAB - cont. of APCDKDE data entry visit re-linker ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ;

NONXCHK ;EP - called from APCDKDE to review A visits

 ;go through all V file entries on other visit

 S APCDKV=APCDKXVS D PROCVF

 S APCDKV=APCDVSIT D PROCVF

 K APCDKV,APCDKOSP,APCDKOPP,APCDK12N,APCDK("C"),APCDKVFL,APCDKIGR,APCDKVDG,APCDVDFN,APCDK("SCORE")

 Q

PROCVF ;process v files

 I APCDVSIT'=APCDKV NEW X,P,S S (S,X)=0,APCDKOSP="" F  S X=$O(^AUPNVPRV("AD",APCDKV,X)) Q:X'=+X  S:$P(^AUPNVPRV(X,0),U,4)="P" APCDKOPP=+^(0) I $P(^(0),U,4)="S"!($P(^(0),U,4)="") S S=S+1,$P(APCDKOSP,U,S)=+^(0)

 S APCDKVFL=9000010 F  S APCDKVFL=$O(^DIC(APCDKVFL)) Q:APCDKVFL>9000010.99!(APCDKVFL'=+APCDKVFL)  D VENTRIES

 Q

 ;

VENTRIES ;

 S APCDKVDG=^DIC(APCDKVFL,0,"GL"),APCDKIGR=APCDKVDG_"""AD"",APCDKV,APCDVDFN)"

 S APCDVDFN="" F APCDVI=1:1 S APCDVDFN=$O(@APCDKIGR) Q:APCDVDFN=""  D SCORE

 Q

 ;

SCORE ;

 Q:$D(APCDK("C",APCDKVFL,APCDVDFN))  ;quit if already reviewe

 S APCDK("C",APCDKVFL,APCDVDFN)=""

 S APCDK12N=APCDKVDG_APCDVDFN_",12)"

 Q:'$D(@(APCDK12N))

 S APCDK12N=@(APCDK12N)

 Q:APCDK12N=""

 S APCDK("SCORE CLIN")=$P(^AUPNVSIT(APCDKXVS,0),U,8),APCDK("SCORE")="APCDKOVS",@APCDK("SCORE")=0,APCDK("SCORE PP")=APCDKOPP,APCDK("SCORE SP")=APCDKOSP D SCORE1

 S APCDK("SCORE CLIN")=$P(APCDKDVR,U,8),APCDK("SCORE")="APCDKDVS",@APCDK("SCORE")=0,APCDK("SCORE PP")=APCDKDPP,APCDK("SCORE SP")=APCDKDSP D SCORE1

 I APCDKV=APCDVSIT,APCDKOVS>APCDKDVS S APCDK("REPOINT V")=APCDKXVS D RELINK Q

 I APCDKV=APCDKXVS,APCDKDVS>APCDKOVS S APCDK("REPOINT V")=APCDVSIT D RELINK Q

 Q

SCORE1 ;

CLINIC ;check clinic

 ;if both v record clinic and visit record clinic are not null, and they match, re-link v record and quit

 I $P(APCDK12N,U,3)]"",APCDK("SCORE CLIN")]"",$P(APCDK12N,U,3)=APCDK("SCORE CLIN") S @APCDK("SCORE")=@APCDK("SCORE")+1

ENCPROV ;

 ;if both v record encounter provider and any provider in V Provider for this visit match, re-link and quit (both must have a value)

 G:$P(APCDK12N,U,4)="" ORDPROV

 I $G(APCDK("SCORE PP"))=$P(APCDK12N,U,4) S @APCDK("SCORE")=@APCDK("SCORE")+1

 S X=0 F I=1:1 S X=$P(APCDK("SCORE SP"),U,I) Q:X=""  I $P(APCDK12N,U,4)=X S @APCDK("SCORE")=@APCDK("SCORE")+1

ORDPROV ;

 G:$P(APCDK12N,U,2)="" SCOREXIT

 I $G(APCDK("SCORE PP"))=$P(APCDK12N,U,2) S @APCDK("SCORE")=@APCDK("SCORE")+1

 S X=0 F I=1:1 S X=$P(APCDK("SCORE SP"),U,I) Q:X=""  I $P(APCDK12N,U,2)=X S @APCDK("SCORE")=@APCDK("SCORE")+1

SCOREXIT ;

 Q

RELINK ;repoint v file entry

 K DIE,DR,DA,DIU,DIV S DITC="",DA=APCDVDFN,DIE=APCDKVDG,DR=".03////"_APCDVSIT D ^DIE K DIE,DA,DR,DIU,DIV,DITC

 Q

SCOREV ;check visit to see if should be deleted

 Q

APCDKDE1  ; IHS/CMI/LAB - cont. of APCDKDE data entry visit re-linker ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;

NONXCHK   ;EP - called from APCDKDE to review A visits

 +1       ;go through all V file entries on other visit

 +2        SET APCDKV=APCDKXVS

           DO PROCVF

 +3        SET APCDKV=APCDVSIT

           DO PROCVF

 +4        KILL APCDKV,APCDKOSP,APCDKOPP,APCDK12N,APCDK("C"),APCDKVFL,APCDKIGR,APCDKVDG,APCDVDFN,APCDK("SCORE")

 +5        QUIT 

PROCVF    ;process v files

 +1        IF APCDVSIT'=APCDKV

               NEW X,P,S

               SET (S,X)=0

               SET APCDKOSP=""

               FOR 

                   SET X=$ORDER(^AUPNVPRV("AD",APCDKV,X))

                   IF X'=+X

                       QUIT 

                   IF $PIECE(^AUPNVPRV(X,0),U,4)="P"

                       SET APCDKOPP=+^(0)

                   IF $PIECE(^(0),U,4)="S"!($PIECE(^(0),U,4)="")

                       SET S=S+1

                       SET $PIECE(APCDKOSP,U,S)=+^(0)

 +2        SET APCDKVFL=9000010

           FOR 

               SET APCDKVFL=$ORDER(^DIC(APCDKVFL))

               IF APCDKVFL>9000010.99!(APCDKVFL'=+APCDKVFL)

                   QUIT 

               DO VENTRIES

 +3        QUIT 

 +4       ;

VENTRIES  ;

 +1        SET APCDKVDG=^DIC(APCDKVFL,0,"GL")

           SET APCDKIGR=APCDKVDG_"""AD"",APCDKV,APCDVDFN)"

 +2        SET APCDVDFN=""

           FOR APCDVI=1:1

               SET APCDVDFN=$ORDER(@APCDKIGR)

               IF APCDVDFN=""

                   QUIT 

               DO SCORE

 +3        QUIT 

 +4       ;

SCORE     ;

 +1       ;quit if already reviewe

           IF $DATA(APCDK("C",APCDKVFL,APCDVDFN))

               QUIT 

 +2        SET APCDK("C",APCDKVFL,APCDVDFN)=""

 +3        SET APCDK12N=APCDKVDG_APCDVDFN_",12)"

 +4        IF '$DATA(@(APCDK12N))

               QUIT 

 +5        SET APCDK12N=@(APCDK12N)

 +6        IF APCDK12N=""

               QUIT 

 +7        SET APCDK("SCORE CLIN")=$PIECE(^AUPNVSIT(APCDKXVS,0),U,8)

           SET APCDK("SCORE")="APCDKOVS"

           SET @APCDK("SCORE")=0

           SET APCDK("SCORE PP")=APCDKOPP

           SET APCDK("SCORE SP")=APCDKOSP

           DO SCORE1

 +8        SET APCDK("SCORE CLIN")=$PIECE(APCDKDVR,U,8)

           SET APCDK("SCORE")="APCDKDVS"

           SET @APCDK("SCORE")=0

           SET APCDK("SCORE PP")=APCDKDPP

           SET APCDK("SCORE SP")=APCDKDSP

           DO SCORE1

 +9        IF APCDKV=APCDVSIT

               IF APCDKOVS>APCDKDVS

                   SET APCDK("REPOINT V")=APCDKXVS

                   DO RELINK

                   QUIT 

 +10       IF APCDKV=APCDKXVS

               IF APCDKDVS>APCDKOVS

                   SET APCDK("REPOINT V")=APCDVSIT

                   DO RELINK

                   QUIT 

 +11       QUIT 

SCORE1    ;

CLINIC    ;check clinic

 +1       ;if both v record clinic and visit record clinic are not null, and they match, re-link v record and quit

 +2        IF $PIECE(APCDK12N,U,3)]""

               IF APCDK("SCORE CLIN")]""

                   IF $PIECE(APCDK12N,U,3)=APCDK("SCORE CLIN")

                       SET @APCDK("SCORE")=@APCDK("SCORE")+1

ENCPROV   ;

 +1       ;if both v record encounter provider and any provider in V Provider for this visit match, re-link and quit (both must have a value)

 +2        IF $PIECE(APCDK12N,U,4)=""

               GOTO ORDPROV

 +3        IF $GET(APCDK("SCORE PP"))=$PIECE(APCDK12N,U,4)

               SET @APCDK("SCORE")=@APCDK("SCORE")+1

 +4        SET X=0

           FOR I=1:1

               SET X=$PIECE(APCDK("SCORE SP"),U,I)

               IF X=""

                   QUIT 

               IF $PIECE(APCDK12N,U,4)=X

                   SET @APCDK("SCORE")=@APCDK("SCORE")+1

ORDPROV   ;

 +1        IF $PIECE(APCDK12N,U,2)=""

               GOTO SCOREXIT

 +2        IF $GET(APCDK("SCORE PP"))=$PIECE(APCDK12N,U,2)

               SET @APCDK("SCORE")=@APCDK("SCORE")+1

 +3        SET X=0

           FOR I=1:1

               SET X=$PIECE(APCDK("SCORE SP"),U,I)

               IF X=""

                   QUIT 

               IF $PIECE(APCDK12N,U,2)=X

                   SET @APCDK("SCORE")=@APCDK("SCORE")+1

SCOREXIT  ;

 +1        QUIT 

RELINK    ;repoint v file entry

 +1        KILL DIE,DR,DA,DIU,DIV

           SET DITC=""

           SET DA=APCDVDFN

           SET DIE=APCDKVDG

           SET DR=".03////"_APCDVSIT

           DO ^DIE

           KILL DIE,DA,DR,DIU,DIV,DITC

 +2        QUIT 

SCOREV    ;check visit to see if should be deleted

 +1        QUIT