Routine: PXAIPRV

PXAIPRV ;ISL/JVS,ESW - SET THE PROVIDER NODES ; 11/25/02 3:36pm

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**5,108**;Aug 12, 1996

PRV ;--CREAT PROVIDERS

SET ;--SET AND NEW VARIABLES

 N AFTER0,AFTER12,AFTER801,AFTER811,AFTER812

 N BEFOR0,BEFOR12,BEFOR801,BEFOR811,BEFOR812

 N PXAA,PXAB,SUB,PIECE,PXAAX,IENB,STOP

 K PXAERR

 S PXAERR(8)=PXAK

 S PXAERR(7)="PROVIDER"

 S SUB="" F  S SUB=$O(@PXADATA@("PROVIDER",PXAK,SUB)) Q:SUB=""  D

 .S PXAA(SUB)=@PXADATA@("PROVIDER",PXAK,SUB)

 ;--VALIDATE ENOUGH DATA

 D VAL^PXAIPRVV Q:$G(STOP)

SETVARA ;--SET VISIT VARIABLES

 S $P(AFTER0,"^",1)=$G(PXAA("NAME"))

 I $G(PXAA("DELETE")) S $P(AFTER0,"^",1)="@"

 S $P(AFTER0,"^",2)=$G(PATIENT)

 S $P(AFTER0,"^",3)=$G(PXAVISIT)

 S $P(AFTER0,"^",4)=$S($G(PXAA("PRIMARY"))=1:"P",1:"S")

 S $P(AFTER0,"^",5)=$S($G(PXAA("ATTENDING"))=1:"A",$G(PXAA("ATTENDING"))=0:"@",1:"")

 S $P(AFTER811,"^",1)=$G(PXAA("COMMENT"))

 S $P(AFTER812,"^",2)=$G(PXAPKG)

 S $P(AFTER812,"^",3)=$G(PXASOURC)

SETPXKA ;--SET PXK ARRAY AFTER

 S ^TMP("PXK",$J,"PRV",PXAK,0,"AFTER")=AFTER0

 S ^TMP("PXK",$J,"PRV",PXAK,811,"AFTER")=AFTER811

 S ^TMP("PXK",$J,"PRV",PXAK,812,"AFTER")=AFTER812

SETVARB ;--SET VARIABLES BEFORE

 ;--CHECK FOR PRIMARY DESIGNATION

 N ITEM,PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI

 D PRV^PXBGPRV(PXAVISIT,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)

 ;CHECK NAME

 S PXAAX("NAME")=$P($G(^VA(200,$G(PXAA("NAME")),0)),"^",1)

 I '$G(PXAPREDT) D

1 .I $D(PRVDR),$P($G(PRVDR("PRIMARY")),U)'=PXAAX("NAME") S PRI=1

2 .I $G(PRI) S $P(^TMP("PXK",$J,"PRV",PXAK,0,"AFTER"),"^",4)="S"

3 .I $G(PRI),$G(PXAA("NAME"))'["@" D VAL04^PXAIPRVV,ERR^PXAI

4 .I $P(AFTER0,"^",4)="P" S PRI=1

 ;--GET IEN FOR 'PXK NODE'

 I $G(PXAA("DELETE"))=1 S PXAAX("NAME")=$P($G(^VA(200,PXAA("NAME"),0)),"^",1)

 S ITEM="" I PXBCNT>0,$G(PXAAX("NAME"))]"" S ITEM=$O(PXBKY(PXAAX("NAME"),0))

 I ITEM]"" S (^TMP("PXK",$J,"PRV",PXAK,"IEN"),IENB)=$O(PXBSKY(ITEM,0))

 I $G(IENB) D

 .F PIECE=0,811,812 S ^TMP("PXK",$J,"PRV",PXAK,PIECE,"BEFORE")=$G(^AUPNVPRV(IENB,PIECE))

 E  D

 .S (BEFOR0,BEFOR811,BEFOR812)=""

.;

SETPXKB .;--SET PXK ARRAY BEFORE

 .S ^TMP("PXK",$J,"PRV",PXAK,0,"BEFORE")=BEFOR0

 .S ^TMP("PXK",$J,"PRV",PXAK,811,"BEFORE")=BEFOR811

 .S ^TMP("PXK",$J,"PRV",PXAK,812,"BEFORE")=BEFOR812

 .S ^TMP("PXK",$J,"PRV",PXAK,"IEN")=""

MISC ;--MISCELLANEOUS NODE

OTHER   ;---ADD OTHER PROVIDERS TO V PROVIDER FOR OTHER ENTRIES

 ; generate data, PXBSKY(), about currently filed providers

 N PXBSKY

 I $G(PXAVISIT) D PRV^PXBGPRV(PXAVISIT,.PXBSKY)

 N IEN,AFTER0,CNT,PXAK,STOP,FF

 S IEN="",CNT=1000

 ;---^TMP("PXAIADDPRV",$J,'IEN')=""

 F  S IEN=$O(^TMP("PXAIADDPRV",$J,IEN)),CNT=CNT+1 Q:IEN=""  D

.;

 .;verify if an entry for a provider already exists

.;

 .S STOP=0

 .I $D(^TMP("PXK",$J,"PRV")) S PXAK="" D  Q:STOP

 ..F  S PXAK=$O(^TMP("PXK",$J,"PRV",PXAK)) Q:PXAK=""  D  Q:STOP

 ...I +$G(^TMP("PXK",$J,"PRV",PXAK,0,"AFTER"))=IEN S STOP=1

 .S FF="PXBSKY" F  S FF=$Q(@FF) Q:FF=""  I @FF=IEN S STOP=1 Q

 .Q:STOP

.;

 .S $P(AFTER0,"^",1)=IEN

 .S $P(AFTER0,"^",2)=$P(^AUPNVSIT(PXAVISIT,0),"^",5)

 .S $P(AFTER0,"^",3)=PXAVISIT

 .S $P(AFTER0,"^",4)="S"

 .S $P(AFTER812,"^",2)=$G(PXAPKG)

 .S $P(AFTER812,"^",3)=$G(PXASOURC)

 .S ^TMP("PXK",$J,"PRV",CNT,0,"AFTER")=$G(AFTER0)

 .S ^TMP("PXK",$J,"PRV",CNT,811,"AFTER")=""

 .S ^TMP("PXK",$J,"PRV",CNT,812,"AFTER")=$G(AFTER812)

 .S ^TMP("PXK",$J,"PRV",CNT,0,"BEFORE")=""

 .S ^TMP("PXK",$J,"PRV",CNT,811,"BEFORE")=""

 .S ^TMP("PXK",$J,"PRV",CNT,811,"BEFORE")=""

 .S ^TMP("PXK",$J,"PRV",CNT,"IEN")=""

PRIM ;--SET A PROVIDER AS PRIMARY

 N PXBCNT,PXBKY,PXBSAM,PXBSKY,AFTER0,FPRI,PRVDR,PXASOR

 D PRV^PXBGPRV(PXAVISIT,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)

 I $D(PRVDR) Q

 I '$D(PXBSKY) Q

 ;----ADDED

 S PXASOR=$G(^TMP("PXK",$J,"SOR"))

 K ^TMP("PXK",$J)

 S ^TMP("PXK",$J,"SOR")=$G(PXASOR)

 S ^TMP("PXK",$J,"VST",1,"IEN")=PXAVISIT

 ;-------

 S $P(AFTER0,"^",1)=$P(^AUPNVPRV($O(PXBSKY(1,0)),0),"^",1)

 S $P(AFTER0,"^",2)=$P(^AUPNVSIT(PXAVISIT,0),"^",5)

 S $P(AFTER0,"^",3)=PXAVISIT

 S $P(AFTER0,"^",4)="P"

 S ^TMP("PXK",$J,"PRV",22222,0,"AFTER")=AFTER0

 S ^TMP("PXK",$J,"PRV",22222,0,"BEFORE")=$G(^AUPNVPRV($O(PXBSKY(1,0)),0))

 S ^TMP("PXK",$J,"PRV",22222,"IEN")=$O(PXBSKY(1,0))

 D EN1^PXKMAIN

 K PXRDR

PXAIPRV   ;ISL/JVS,ESW - SET THE PROVIDER NODES ; 11/25/02 3:36pm

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**5,108**;Aug 12, 1996

 +2       ;

 +3        QUIT

PRV       ;--CREAT PROVIDERS

 +1       ;

SET       ;--SET AND NEW VARIABLES

 +1        NEW AFTER0,AFTER12,AFTER801,AFTER811,AFTER812

 +2        NEW BEFOR0,BEFOR12,BEFOR801,BEFOR811,BEFOR812

 +3        NEW PXAA,PXAB,SUB,PIECE,PXAAX,IENB,STOP

 +4       ;

 +5        KILL PXAERR

 +6        SET PXAERR(8)=PXAK

 +7        SET PXAERR(7)="PROVIDER"

 +8       ;

 +9        SET SUB=""

FOR

               SET SUB=$ORDER(@PXADATA@("PROVIDER",PXAK,SUB))

               IF SUB=""

                   QUIT

               Begin DoDot:1

 +10               SET PXAA(SUB)=@PXADATA@("PROVIDER",PXAK,SUB)

               End DoDot:1

 +11      ;

 +12      ;--VALIDATE ENOUGH DATA

 +13       DO VAL^PXAIPRVV

           IF $GET(STOP)

               QUIT

 +14      ;

SETVARA   ;--SET VISIT VARIABLES

 +1        SET $PIECE(AFTER0,"^",1)=$GET(PXAA("NAME"))

 +2        IF $GET(PXAA("DELETE"))

               SET $PIECE(AFTER0,"^",1)="@"

 +3        SET $PIECE(AFTER0,"^",2)=$GET(PATIENT)

 +4        SET $PIECE(AFTER0,"^",3)=$GET(PXAVISIT)

 +5        SET $PIECE(AFTER0,"^",4)=$SELECT($GET(PXAA("PRIMARY"))=1:"P",1:"S")

 +6        SET $PIECE(AFTER0,"^",5)=$SELECT($GET(PXAA("ATTENDING"))=1:"A",$GET(PXAA("ATTENDING"))=0:"@",1:"")

 +7        SET $PIECE(AFTER811,"^",1)=$GET(PXAA("COMMENT"))

 +8       ;

 +9       ;

 +10       SET $PIECE(AFTER812,"^",2)=$GET(PXAPKG)

 +11       SET $PIECE(AFTER812,"^",3)=$GET(PXASOURC)

 +12      ;

SETPXKA   ;--SET PXK ARRAY AFTER

 +1        SET ^TMP("PXK",$JOB,"PRV",PXAK,0,"AFTER")=AFTER0

 +2        SET ^TMP("PXK",$JOB,"PRV",PXAK,811,"AFTER")=AFTER811

 +3        SET ^TMP("PXK",$JOB,"PRV",PXAK,812,"AFTER")=AFTER812

 +4       ;

SETVARB   ;--SET VARIABLES BEFORE

 +1       ;

 +2       ;--CHECK FOR PRIMARY DESIGNATION

 +3        NEW ITEM,PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI

 +4        DO PRV^PXBGPRV(PXAVISIT,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)

 +5       ;CHECK NAME

 +6        SET PXAAX("NAME")=$PIECE($GET(^VA(200,$GET(PXAA("NAME")),0)),"^",1)

 +7        IF '$GET(PXAPREDT)

               Begin DoDot:1

1                  IF $DATA(PRVDR)

                       IF $PIECE($GET(PRVDR("PRIMARY")),U)'=PXAAX("NAME")

                           SET PRI=1

2                  IF $GET(PRI)

                       SET $PIECE(^TMP("PXK",$JOB,"PRV",PXAK,0,"AFTER"),"^",4)="S"

3                  IF $GET(PRI)

                       IF $GET(PXAA("NAME"))'["@"

                           DO VAL04^PXAIPRVV

                           DO ERR^PXAI

4                  IF $PIECE(AFTER0,"^",4)="P"

                       SET PRI=1

               End DoDot:1

 +1       ;

 +2       ;--GET IEN FOR 'PXK NODE'

 +3        IF $GET(PXAA("DELETE"))=1

               SET PXAAX("NAME")=$PIECE($GET(^VA(200,PXAA("NAME"),0)),"^",1)

 +4        SET ITEM=""

           IF PXBCNT>0

               IF $GET(PXAAX("NAME"))]""

                   SET ITEM=$ORDER(PXBKY(PXAAX("NAME"),0))

 +5        IF ITEM]""

               SET (^TMP("PXK",$JOB,"PRV",PXAK,"IEN"),IENB)=$ORDER(PXBSKY(ITEM,0))

 +6       ;

 +7        IF $GET(IENB)

               Begin DoDot:1

 +8                FOR PIECE=0,811,812

                       SET ^TMP("PXK",$JOB,"PRV",PXAK,PIECE,"BEFORE")=$GET(^AUPNVPRV(IENB,PIECE))

               End DoDot:1

 +9       IF '$TEST

               Begin DoDot:1

 +10               SET (BEFOR0,BEFOR811,BEFOR812)=""

 +11      ;

SETPXKB   ;--SET PXK ARRAY BEFORE

 +1                SET ^TMP("PXK",$JOB,"PRV",PXAK,0,"BEFORE")=BEFOR0

 +2                SET ^TMP("PXK",$JOB,"PRV",PXAK,811,"BEFORE")=BEFOR811

 +3                SET ^TMP("PXK",$JOB,"PRV",PXAK,812,"BEFORE")=BEFOR812

 +4                SET ^TMP("PXK",$JOB,"PRV",PXAK,"IEN")=""

               End DoDot:1

 +5       ;

MISC      ;--MISCELLANEOUS NODE

 +1       ;

 +2        QUIT

OTHER     ;---ADD OTHER PROVIDERS TO V PROVIDER FOR OTHER ENTRIES

 +1       ;

 +2       ; generate data, PXBSKY(), about currently filed providers

 +3       ;

 +4        NEW PXBSKY

 +5        IF $GET(PXAVISIT)

               DO PRV^PXBGPRV(PXAVISIT,.PXBSKY)

 +6       ;

 +7        NEW IEN,AFTER0,CNT,PXAK,STOP,FF

 +8        SET IEN=""

           SET CNT=1000

 +9       ;

 +10      ;---^TMP("PXAIADDPRV",$J,'IEN')=""

 +11      ;

 +12       FOR

               SET IEN=$ORDER(^TMP("PXAIADDPRV",$JOB,IEN))

               SET CNT=CNT+1

               IF IEN=""

                   QUIT

               Begin DoDot:1

 +13      ;

 +14      ;verify if an entry for a provider already exists

 +15      ;

 +16               SET STOP=0

 +17               IF $DATA(^TMP("PXK",$JOB,"PRV"))

                       SET PXAK=""

                       Begin DoDot:2

 +18                       FOR

                               SET PXAK=$ORDER(^TMP("PXK",$JOB,"PRV",PXAK))

                               IF PXAK=""

                                   QUIT

                               Begin DoDot:3

 +19                               IF +$GET(^TMP("PXK",$JOB,"PRV",PXAK,0,"AFTER"))=IEN

                                       SET STOP=1

                               End DoDot:3

                               IF STOP

                                   QUIT

                       End DoDot:2

                       IF STOP

                           QUIT

 +20               SET FF="PXBSKY"

FOR

                       SET FF=$QUERY(@FF)

                       IF FF=""

                           QUIT

                       IF @FF=IEN

                           SET STOP=1

                           QUIT

 +21               IF STOP

                       QUIT

 +22      ;

 +23               SET $PIECE(AFTER0,"^",1)=IEN

 +24               SET $PIECE(AFTER0,"^",2)=$PIECE(^AUPNVSIT(PXAVISIT,0),"^",5)

 +25               SET $PIECE(AFTER0,"^",3)=PXAVISIT

 +26               SET $PIECE(AFTER0,"^",4)="S"

 +27               SET $PIECE(AFTER812,"^",2)=$GET(PXAPKG)

 +28               SET $PIECE(AFTER812,"^",3)=$GET(PXASOURC)

 +29               SET ^TMP("PXK",$JOB,"PRV",CNT,0,"AFTER")=$GET(AFTER0)

 +30               SET ^TMP("PXK",$JOB,"PRV",CNT,811,"AFTER")=""

 +31               SET ^TMP("PXK",$JOB,"PRV",CNT,812,"AFTER")=$GET(AFTER812)

 +32               SET ^TMP("PXK",$JOB,"PRV",CNT,0,"BEFORE")=""

 +33               SET ^TMP("PXK",$JOB,"PRV",CNT,811,"BEFORE")=""

 +34               SET ^TMP("PXK",$JOB,"PRV",CNT,811,"BEFORE")=""

 +35               SET ^TMP("PXK",$JOB,"PRV",CNT,"IEN")=""

               End DoDot:1

 +36       QUIT

PRIM      ;--SET A PROVIDER AS PRIMARY

 +1        NEW PXBCNT,PXBKY,PXBSAM,PXBSKY,AFTER0,FPRI,PRVDR,PXASOR

 +2        DO PRV^PXBGPRV(PXAVISIT,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)

 +3        IF $DATA(PRVDR)

               QUIT

 +4        IF '$DATA(PXBSKY)

               QUIT

 +5       ;----ADDED

 +6        SET PXASOR=$GET(^TMP("PXK",$JOB,"SOR"))

 +7        KILL ^TMP("PXK",$JOB)

 +8        SET ^TMP("PXK",$JOB,"SOR")=$GET(PXASOR)

 +9        SET ^TMP("PXK",$JOB,"VST",1,"IEN")=PXAVISIT

 +10      ;-------

 +11      ;

 +12       SET $PIECE(AFTER0,"^",1)=$PIECE(^AUPNVPRV($ORDER(PXBSKY(1,0)),0),"^",1)

 +13       SET $PIECE(AFTER0,"^",2)=$PIECE(^AUPNVSIT(PXAVISIT,0),"^",5)

 +14       SET $PIECE(AFTER0,"^",3)=PXAVISIT

 +15       SET $PIECE(AFTER0,"^",4)="P"

 +16       SET ^TMP("PXK",$JOB,"PRV",22222,0,"AFTER")=AFTER0

 +17       SET ^TMP("PXK",$JOB,"PRV",22222,0,"BEFORE")=$GET(^AUPNVPRV($ORDER(PXBSKY(1,0)),0))

 +18       SET ^TMP("PXK",$JOB,"PRV",22222,"IEN")=$ORDER(PXBSKY(1,0))

 +19       DO EN1^PXKMAIN

 +20       KILL PXRDR

 +21       QUIT

PXAIPRV.m