AVAP3.m

AVAP3 ;IHS/ORDC/LJF - MOVE LICENSURE BACK TO FILE 6 [ 10/27/93  9:47 AM ]

 ;;93.2;VA SUPPORT FILES**3**;Jul 17, 1992;;Build 12

 ;

 Q  ;no direct entry to rtn

 ;

LOOP ; loop thru provider file

 Q:'$O(^DIC(6,0))  ;no data in provider file

 W !!,"Moving licensure data back to Provider file "

 S LJF6=0

 F  S LJF6=$O(^DIC(6,LJF6)) Q:LJF6'=+LJF6  D

 .Q:'$D(^DIC(6,LJF6,0))  ;bad entry

 .Q:$P(^DIC(6,LJF6,0),U)'=LJF6  ;also bad entry

 .I LJF6#10=0 W ". "

 .I '$D(^DIC(16,LJF6,"A3")) D  Q

 ..W !,"^DIC(16,",LJF6,",""A3"" DOES NOT EXIST.",!

 .S LJF200=$P(^DIC(16,LJF6,"A3"),U) ;user pointer

 .I LJF200="" D  Q

 ..W !,"^DIC(16,",LJF6," HAS NO A3 POINTER TO ^DIC(3.",!

 .Q:'$D(^VA(200,LJF200))  ;no entry in file 200

 .D MOVE ;move then delete licensure multiple

 .Q  ;get next provider

 ;

 ;

END ;***> eoj

 K LJF6,LJF200

 K X,Y Q

 ;

 ;

 ;

 ;

MOVE ;**> SUBRTN to move licensure data to file 6 then delete in file 200

 Q:'$O(^VA(200,LJF200,"PS1",0))  ;no data to move

 I $O(^DIC(6,LJF6,999999921,0)) G MOVE1 ;data in file 6; don't overwrite

 S ^DIC(6,LJF6,999999921,0)="^6.999999921P^"_$P(^VA(200,LJF200,"PS1",0),U,3,4) ;set zero node

 W "+ " S X=0

 F  S X=$O(^VA(200,LJF200,"PS1",X)) Q:X'=+X  D

 .S ^DIC(6,LJF6,999999921,X,0)=^VA(200,LJF200,"PS1",X,0)

MOVE1 K ^VA(200,LJF200,"PS1") ;remove data from file 200

 Q

AVAP3     ;IHS/ORDC/LJF - MOVE LICENSURE BACK TO FILE 6 [ 10/27/93  9:47 AM ]

 +1       ;;93.2;VA SUPPORT FILES**3**;Jul 17, 1992;;Build 12

 +2       ;

 +3       ;no direct entry to rtn

           QUIT 

 +4       ;

LOOP      ; loop thru provider file

 +1       ;no data in provider file

           IF '$ORDER(^DIC(6,0))

               QUIT 

 +2        WRITE !!,"Moving licensure data back to Provider file "

 +3        SET LJF6=0

 +4        FOR 

               SET LJF6=$ORDER(^DIC(6,LJF6))

               IF LJF6'=+LJF6

                   QUIT 

               Begin DoDot:1

 +5       ;bad entry

                   IF '$DATA(^DIC(6,LJF6,0))

                       QUIT 

 +6       ;also bad entry

                   IF $PIECE(^DIC(6,LJF6,0),U)'=LJF6

                       QUIT 

 +7                IF LJF6#10=0

                       WRITE ". "

 +8                IF '$DATA(^DIC(16,LJF6,"A3"))

                       Begin DoDot:2

 +9                        WRITE !,"^DIC(16,",LJF6,",""A3"" DOES NOT EXIST.",!

                       End DoDot:2

                       QUIT 

 +10      ;user pointer

                   SET LJF200=$PIECE(^DIC(16,LJF6,"A3"),U)

 +11               IF LJF200=""

                       Begin DoDot:2

 +12                       WRITE !,"^DIC(16,",LJF6," HAS NO A3 POINTER TO ^DIC(3.",!

                       End DoDot:2

                       QUIT 

 +13      ;no entry in file 200

                   IF '$DATA(^VA(200,LJF200))

                       QUIT 

 +14      ;move then delete licensure multiple

                   DO MOVE

 +15      ;get next provider

                   QUIT 

               End DoDot:1

 +16      ;

 +17      ;

END       ;***> eoj

 +1        KILL LJF6,LJF200

 +2        KILL X,Y

           QUIT 

 +3       ;

 +4       ;

 +5       ;

 +6       ;

MOVE      ;**> SUBRTN to move licensure data to file 6 then delete in file 200

 +1       ;no data to move

           IF '$ORDER(^VA(200,LJF200,"PS1",0))

               QUIT 

 +2       ;data in file 6; don't overwrite

           IF $ORDER(^DIC(6,LJF6,999999921,0))

               GOTO MOVE1

 +3       ;set zero node

           SET ^DIC(6,LJF6,999999921,0)="^6.999999921P^"_$PIECE(^VA(200,LJF200,"PS1",0),U,3,4)

 +4        WRITE "+ "

           SET X=0

 +5        FOR 

               SET X=$ORDER(^VA(200,LJF200,"PS1",X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET ^DIC(6,LJF6,999999921,X,0)=^VA(200,LJF200,"PS1",X,0)

               End DoDot:1

MOVE1     ;remove data from file 200

           KILL ^VA(200,LJF200,"PS1")

 +1        QUIT