APCLV07.m

APCLV07 ; IHS/CMI/LAB - provider functions ;

 ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58

 ;

PRIMPOV ;EP - primary provider in many different formats

 I 'V Q -1

 I '$D(^AUPNVSIT(V)) Q -1

 NEW %,Y,P,C,Z

 S (Z,P)="",(Y,C)=0

 I $P(^AUPNVSIT(V,0),U,7)="H" F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y  I $P(^AUPNVPOV(Y,0),U,12)="P" S P=$P(^AUPNVPOV(Y,0),U),Z=Y

 I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=$O(^AUPNVPOV("AD",V,0)) I Y S P=$P($G(^AUPNVPOV(Y,0)),U),Z=Y

 I 'P Q P

 I '$D(^ICD9(P)) Q -1

 I $G(F)="" S F="C"

 S %="" D @F

 Q %

 ;

SECPOV ;EP

 I 'V Q -1

 I '$D(^AUPNVSIT(V)) Q -1

 I '$G(N) Q -1

 NEW %,Y,P,C,Z

 S (Z,P)="",(Y,C)=0

 I $P(^AUPNVSIT(V,0),U,7)="H" F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y  I $P(^AUPNVPOV(Y,0),U,12)'="P" S C=C+1 I C=N S P=$P(^AUPNVPOV(Y,0),U),Z=Y

 I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=0,C=-1 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AUPNVPOV(Y,0),U),Z=Y

 I 'P Q P

 I '$D(^ICD9(P)) Q -1

 I $G(F)="" S F="C"

 S %="" D @F

 Q %

 ;

POV ;EP

 NEW Z,C,%,S,I,J

 S (C,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y   S C=C+1 S APCLV(C)="",P=$P(^AUPNVPOV(Y,0),U),Z=Y D

 .I F=99 D  Q

 ..F I=1:1 S S=$T(@I) Q:S=""  S %="" D @I S $P(APCLV(C),U,I)=%

 .I F[";" D  Q

 ..F J=1:1 S I=$P(F,";",J) Q:I=""  I I'=99 S %="" D @I S $P(APCLV(C),U,I)=% ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J

 .S %="",I=F D @I S $P(APCLV(C),U)=%

 .Q

 Q

ADMDX ;EP

 I 'V Q -1

 I '$D(^AUPNVSIT(V)) Q -1

 NEW %,Y,Z

 S %="",Z=$O(^AUPNVINP("AD",V,0))

 I 'Z Q %

 S P=$P(^AUPNVINP(Z,0),U,12)

 I 'P Q P

 I '$D(^ICD9(P)) Q -1

 I $G(F)="" S F="C"

 S %="" D @F

 Q %

 ;

I ;

 S %=P Q

E ;

 ;S %=$P(^ICD9(P,0),U,3) Q  ;cmi/anch/maw 9/12/2007 orig line

 S %=$P($$ICDDX^ICDEX(P,,,"I"),U,4) Q  ;cmi/anch/maw 9/12/2007 csv

C ;

 ;S %=$P(^ICD9(P,0),U) Q  ;cmi/anch/maw 9/12/2007 orig line

 S %=$P($$ICDDX^ICDEX(P,,,"I"),U,2) Q  ;cmi/anch/maw 9/12/2007 csv

D ;

 S %=$P(^AUPNVPOV(Z,0),U,7) Q

J ;

 ;S %=$P(^AUPNVPOV(Z,0),U,9) I % S %=$P(^ICD9(%,0),U) Q  ;cmi/anch/maw 9/12/2007 orig line

 S %=$P(^AUPNVPOV(Z,0),U,9) I % S %=$P($$ICDDX^ICDEX(%),U,2) Q  ;cmi/anch/maw 9/12/2007 csc

 Q

P ;

 S %=$P(^AUPNVPOV(Z,0),U,11) Q

N ;

 S %=$$VAL^XBDIQ1(9000010.07,Z,.04)

 ;S %=$P(^AUPNVPOV(Z,0),U,4) I %,$D(^AUTNPOV(%,0)) S %=$P(^AUTNPOV(%,0),U)

 Q

S ;stage

 S %=$P(^AUPNVPOV(Z,0),U,5) Q

A ;

 NEW I,H,R,L,E,D

 ;S I=$P(^ICD9(P,0),U)  ;cmi/anch/maw 9/12/2007 orig line

 S I=$P($$ICDDX^ICDEX(P),U,2)  ;cmi/anch/maw 9/12/2007 csv

 I $E(I)="E" S %=999 Q

 I $E(I)="." D CODE10 G HIGH

 S R="09"_($P(I,".")_$P(I,".",2))_" "

 I $E(I)="V" S I=9_$E(I,2,9999),I=I-.000001,I="09V"_$E(I,2,9999),I=$P(I,".")_$P(I,".",2)_" " G HIGH

 S I="09"_I-.000001

 S %="",I="0"_($P(I,".")_$P(I,".",2))_" "

HIGH S H=$O(^AUTTRCD("AH",I)) I H="" S %=999 Q

 S D=$O(^AUTTRCD("AH",H,"")) I D="" S %="" Q

 S E=$O(^AUTTRCD("AH",H,D,""))

 S L=$P(^AUTTRCD(D,11,E,0),U)_" "

 I L]R S %=999 Q

 S %=$P(^AUTTRCD(D,0),U)

 Q

CODE10 ;

 S R="10"_$P(I,".",2)_" "

 S I="10"_I,I=I-.000001,I=$P(I,".")_$P(I,".",2)_" "

 Q

 ;

1 ;

 S %=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3),"I")

 Q

2 ;

 S %=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3),"S")

 Q

3 ;

 S %=$P(^AUPNVPOV(Y,0),U,2)

 Q

4 ;

 S %=$$PATIENT^APCLV($P(^AUPNVPOV(Y,0),U,3),"E")

 Q

5 ;

 S %=Y

 Q

6 D E Q

7 D C Q

8 D A Q

9 D D Q

10 S %=$$VAL^XBDIQ1(9000010.07,Y,.07) Q

11 D J Q

12 D P Q

13 S %=$$VAL^XBDIQ1(9000010.07,Y,.11) Q

14 D N Q

15 S %=$P(^AUPNVPOV(Y,0),U,12) Q

16 S %=$$VAL^XBDIQ1(9000010.07,Y,.12) Q

17 S %=$$VAL^XBDIQ1(9000010.07,Y,.13) Q

18 S %=$$VAL^XBDIQ1(9000010.07,Y,.05) Q

19 S %=$$VALI^XBDIQ1(9000010.07,Y,.06) Q

20 S %=$$VAL^XBDIQ1(9000010.07,Y,.06) Q

APCLV07   ; IHS/CMI/LAB - provider functions ;

 +1       ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58

 +2       ;

PRIMPOV   ;EP - primary provider in many different formats

 +1        IF 'V

               QUIT -1

 +2        IF '$DATA(^AUPNVSIT(V))

               QUIT -1

 +3        NEW %,Y,P,C,Z

 +4        SET (Z,P)=""

           SET (Y,C)=0

 +5        IF $PIECE(^AUPNVSIT(V,0),U,7)="H"

               FOR 

                   SET Y=$ORDER(^AUPNVPOV("AD",V,Y))

                   IF Y'=+Y

                       QUIT 

                   IF $PIECE(^AUPNVPOV(Y,0),U,12)="P"

                       SET P=$PIECE(^AUPNVPOV(Y,0),U)

                       SET Z=Y

 +6        IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"

               SET Y=$ORDER(^AUPNVPOV("AD",V,0))

               IF Y

                   SET P=$PIECE($GET(^AUPNVPOV(Y,0)),U)

                   SET Z=Y

 +7        IF 'P

               QUIT P

 +8        IF '$DATA(^ICD9(P))

               QUIT -1

 +9        IF $GET(F)=""

               SET F="C"

 +10       SET %=""

           DO @F

 +11       QUIT %

 +12      ;

SECPOV    ;EP

 +1        IF 'V

               QUIT -1

 +2        IF '$DATA(^AUPNVSIT(V))

               QUIT -1

 +3        IF '$GET(N)

               QUIT -1

 +4        NEW %,Y,P,C,Z

 +5        SET (Z,P)=""

           SET (Y,C)=0

 +6        IF $PIECE(^AUPNVSIT(V,0),U,7)="H"

               FOR 

                   SET Y=$ORDER(^AUPNVPOV("AD",V,Y))

                   IF Y'=+Y

                       QUIT 

                   IF $PIECE(^AUPNVPOV(Y,0),U,12)'="P"

                       SET C=C+1

                       IF C=N

                           SET P=$PIECE(^AUPNVPOV(Y,0),U)

                           SET Z=Y

 +7        IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"

               SET Y=0

               SET C=-1

               FOR 

                   SET Y=$ORDER(^AUPNVPOV("AD",V,Y))

                   IF Y'=+Y

                       QUIT 

                   SET C=C+1

                   IF C=N

                       SET P=$PIECE(^AUPNVPOV(Y,0),U)

                       SET Z=Y

 +8        IF 'P

               QUIT P

 +9        IF '$DATA(^ICD9(P))

               QUIT -1

 +10       IF $GET(F)=""

               SET F="C"

 +11       SET %=""

           DO @F

 +12       QUIT %

 +13      ;

POV       ;EP

 +1        NEW Z,C,%,S,I,J

 +2        SET (C,Y)=0

           FOR 

               SET Y=$ORDER(^AUPNVPOV("AD",V,Y))

               IF Y'=+Y

                   QUIT 

               SET C=C+1

               SET APCLV(C)=""

               SET P=$PIECE(^AUPNVPOV(Y,0),U)

               SET Z=Y

               Begin DoDot:1

 +3                IF F=99

                       Begin DoDot:2

 +4                        FOR I=1:1

                               SET S=$TEXT(@I)

                               IF S=""

                                   QUIT 

                               SET %=""

                               DO @I

                               SET $PIECE(APCLV(C),U,I)=%

                       End DoDot:2

                       QUIT 

 +5                IF F[";"

                       Begin DoDot:2

 +6       ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J

                           FOR J=1:1

                               SET I=$PIECE(F,";",J)

                               IF I=""

                                   QUIT 

                               IF I'=99

                                   SET %=""

                                   DO @I

                                   SET $PIECE(APCLV(C),U,I)=%

                       End DoDot:2

                       QUIT 

 +7                SET %=""

                   SET I=F

                   DO @I

                   SET $PIECE(APCLV(C),U)=%

 +8                QUIT 

               End DoDot:1

 +9        QUIT 

ADMDX     ;EP

 +1        IF 'V

               QUIT -1

 +2        IF '$DATA(^AUPNVSIT(V))

               QUIT -1

 +3        NEW %,Y,Z

 +4        SET %=""

           SET Z=$ORDER(^AUPNVINP("AD",V,0))

 +5        IF 'Z

               QUIT %

 +6        SET P=$PIECE(^AUPNVINP(Z,0),U,12)

 +7        IF 'P

               QUIT P

 +8        IF '$DATA(^ICD9(P))

               QUIT -1

 +9        IF $GET(F)=""

               SET F="C"

 +10       SET %=""

           DO @F

 +11       QUIT %

 +12      ;

I         ;

 +1        SET %=P

           QUIT 

E         ;

 +1       ;S %=$P(^ICD9(P,0),U,3) Q  ;cmi/anch/maw 9/12/2007 orig line

 +2       ;cmi/anch/maw 9/12/2007 csv

           SET %=$PIECE($$ICDDX^ICDEX(P,,,"I"),U,4)

           QUIT 

C         ;

 +1       ;S %=$P(^ICD9(P,0),U) Q  ;cmi/anch/maw 9/12/2007 orig line

 +2       ;cmi/anch/maw 9/12/2007 csv

           SET %=$PIECE($$ICDDX^ICDEX(P,,,"I"),U,2)

           QUIT 

D         ;

 +1        SET %=$PIECE(^AUPNVPOV(Z,0),U,7)

           QUIT 

J         ;

 +1       ;S %=$PCLV07_source.html#xP">P(^AUPCLV07_source.html#xP">PNVPCLV07_source.html#xP">POV(Z,0),U,9) I % S %=$PCLV07_source.html#xP">P(^ICD9(%,0),U) Q  ;cmi/anch/maw 9/12/2007 orig line

 +2       ;cmi/anch/maw 9/12/2007 csc

           SET %=$PIECE(^AUPNVPOV(Z,0),U,9)

           IF %

               SET %=$PIECE($$ICDDX^ICDEX(%),U,2)

               QUIT 

 +3        QUIT 

P         ;

 +1        SET %=$PIECE(^AUPNVPOV(Z,0),U,11)

           QUIT 

N         ;

 +1        SET %=$$VAL^XBDIQ1(9000010.07,Z,.04)

 +2       ;S %=$PCLV07_source.html#xP">P(^AUPCLV07_source.html#xP">PNVPCLV07_source.html#xP">POV(Z,0),U,4) I %,$PCLV07_source.html#xD">D(^AUTNPCLV07_source.html#xP">POV(%,0)) S %=$PCLV07_source.html#xP">P(^AUTNPCLV07_source.html#xP">POV(%,0),U)

 +3        QUIT 

S         ;stage

 +1        SET %=$PIECE(^AUPNVPOV(Z,0),U,5)

           QUIT 

A         ;

 +1        NEW I,H,R,L,E,D

 +2       ;S I=$P(^ICD9(P,0),U)  ;cmi/anch/maw 9/12/2007 orig line

 +3       ;cmi/anch/maw 9/12/2007 csv

           SET I=$PIECE($$ICDDX^ICDEX(P),U,2)

 +4        IF $EXTRACT(I)="E"

               SET %=999

               QUIT 

 +5        IF $EXTRACT(I)="."

               DO CODE10

               GOTO HIGH

 +6        SET R="09"_($PIECE(I,".")_$PIECE(I,".",2))_" "

 +7        IF $EXTRACT(I)="V"

               SET I=9_$EXTRACT(I,2,9999)

               SET I=I-.000001

               SET I="09V"_$EXTRACT(I,2,9999)

               SET I=$PIECE(I,".")_$PIECE(I,".",2)_" "

               GOTO HIGH

 +8        SET I="09"_I-.000001

 +9        SET %=""

           SET I="0"_($PIECE(I,".")_$PIECE(I,".",2))_" "

HIGH       SET H=$ORDER(^AUTTRCD("AH",I))

           IF H=""

               SET %=999

               QUIT 

 +1        SET D=$ORDER(^AUTTRCD("AH",H,""))

           IF D=""

               SET %=""

               QUIT 

 +2        SET E=$ORDER(^AUTTRCD("AH",H,D,""))

 +3        SET L=$PIECE(^AUTTRCD(D,11,E,0),U)_" "

 +4        IF L]R

               SET %=999

               QUIT 

 +5        SET %=$PIECE(^AUTTRCD(D,0),U)

 +6        QUIT 

CODE10    ;

 +1        SET R="10"_$PIECE(I,".",2)_" "

 +2        SET I="10"_I

           SET I=I-.000001

           SET I=$PIECE(I,".")_$PIECE(I,".",2)_" "

 +3        QUIT 

 +4       ;

1         ;

 +1        SET %=$$VD^APCLV($PIECE(^AUPNVPOV(Y,0),U,3),"I")

 +2        QUIT 

2         ;

 +1        SET %=$$VD^APCLV($PIECE(^AUPNVPOV(Y,0),U,3),"S")

 +2        QUIT 

3         ;

 +1        SET %=$PIECE(^AUPNVPOV(Y,0),U,2)

 +2        QUIT 

4         ;

 +1        SET %=$$PATIENT^APCLV($PIECE(^AUPNVPOV(Y,0),U,3),"E")

 +2        QUIT 

5         ;

 +1        SET %=Y

 +2        QUIT 

6          DO E

           QUIT 

7          DO C

           QUIT 

8          DO A

           QUIT 

9          DO D

           QUIT 

10         SET %=$$VAL^XBDIQ1(9000010.07,Y,.07)

           QUIT 

11         DO J

           QUIT 

12         DO P

           QUIT 

13         SET %=$$VAL^XBDIQ1(9000010.07,Y,.11)

           QUIT 

14         DO N

           QUIT 

15         SET %=$PIECE(^AUPNVPOV(Y,0),U,12)

           QUIT 

16         SET %=$$VAL^XBDIQ1(9000010.07,Y,.12)

           QUIT 

17         SET %=$$VAL^XBDIQ1(9000010.07,Y,.13)

           QUIT 

18         SET %=$$VAL^XBDIQ1(9000010.07,Y,.05)

           QUIT 

19         SET %=$$VALI^XBDIQ1(9000010.07,Y,.06)

           QUIT 

20         SET %=$$VAL^XBDIQ1(9000010.07,Y,.06)

           QUIT